{-# LANGUAGE OverloadedLists #-}

module Vulkan.Utils.Initialization
  ( createDebugInstanceWithExtensions
  , createInstanceWithExtensions
  , pickPhysicalDevice
  , physicalDeviceName
  , createDeviceWithExtensions
  ) where

import           Control.Exception              ( throwIO )
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Resource
import           Data.Bits
import           Data.ByteString                ( ByteString )
import           Data.Foldable
import           Data.Maybe
import           Data.Ord
import           Data.Text                      ( Text )
import           Data.Text.Encoding             ( decodeUtf8 )
import qualified Data.Vector                   as V
import           GHC.IO.Exception               ( IOErrorType(NoSuchThing)
                                                , IOException(..)
                                                )
import           Vulkan.CStruct.Extends
import           Vulkan.Core10
import           Vulkan.Extensions.VK_EXT_debug_utils
import           Vulkan.Extensions.VK_EXT_validation_features
import           Vulkan.Utils.Debug
import           Vulkan.Utils.Misc
import           Vulkan.Zero

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

-- | Like 'createInstanceWithExtensions' except it will create a debug utils
-- messenger (from the @VK_EXT_debug_utils@ extension).
--
-- If the @VK_EXT_validation_features@ extension (from the
-- @VK_LAYER_KHRONOS_validation@ layer) is available is it will be enabled and
-- best practices messages enabled.
createDebugInstanceWithExtensions
  :: forall es m
   . (Extendss InstanceCreateInfo es, PokeChain es, MonadResource m)
  => [ByteString]
  -- ^ Required layers
  -> [ByteString]
  -- ^ Optional layers
  -> [ByteString]
  -- ^ Required extensions
  -> [ByteString]
  -- ^ Optional extensions
  -> InstanceCreateInfo es
  -> m Instance
createDebugInstanceWithExtensions :: [ByteString]
-> [ByteString]
-> [ByteString]
-> [ByteString]
-> InstanceCreateInfo es
-> m Instance
createDebugInstanceWithExtensions requiredLayers :: [ByteString]
requiredLayers optionalLayers :: [ByteString]
optionalLayers requiredExtensions :: [ByteString]
requiredExtensions optionalExtensions :: [ByteString]
optionalExtensions instanceCreateInfo :: InstanceCreateInfo es
instanceCreateInfo
  = do
    let debugMessengerCreateInfo :: DebugUtilsMessengerCreateInfoEXT
debugMessengerCreateInfo = DebugUtilsMessengerCreateInfoEXT
forall a. Zero a => a
zero
          { $sel:messageSeverity:DebugUtilsMessengerCreateInfoEXT :: DebugUtilsMessageSeverityFlagsEXT
messageSeverity = DebugUtilsMessageSeverityFlagsEXT
DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT
                                DebugUtilsMessageSeverityFlagsEXT
-> DebugUtilsMessageSeverityFlagsEXT
-> DebugUtilsMessageSeverityFlagsEXT
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
                              DebugUtilsMessageTypeFlagsEXT
-> DebugUtilsMessageTypeFlagsEXT -> DebugUtilsMessageTypeFlagsEXT
forall a. Bits a => a -> a -> a
.|. DebugUtilsMessageTypeFlagsEXT
DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT
                              DebugUtilsMessageTypeFlagsEXT
-> DebugUtilsMessageTypeFlagsEXT -> DebugUtilsMessageTypeFlagsEXT
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
          [Item (Vector ValidationFeatureEnableEXT)
ValidationFeatureEnableEXT
VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT]
          []
        instanceCreateInfo'
          :: InstanceCreateInfo
               (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
        instanceCreateInfo' :: InstanceCreateInfo
  (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo' = InstanceCreateInfo es
instanceCreateInfo
          { $sel:next:InstanceCreateInfo :: Chain
  (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
next = DebugUtilsMessengerCreateInfoEXT
debugMessengerCreateInfo DebugUtilsMessengerCreateInfoEXT
-> Chain (ValidationFeaturesEXT : es)
-> Chain
     (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ValidationFeaturesEXT
validationFeatures ValidationFeaturesEXT
-> Chain es -> Chain (ValidationFeaturesEXT : es)
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& InstanceCreateInfo es -> Chain es
forall (es :: [*]). InstanceCreateInfo es -> Chain es
next
                     (InstanceCreateInfo es
instanceCreateInfo :: InstanceCreateInfo es)
          }
    Instance
inst <- [ByteString]
-> [ByteString]
-> [ByteString]
-> [ByteString]
-> InstanceCreateInfo
     (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
-> m Instance
forall (es :: [*]) (m :: * -> *).
(Extendss InstanceCreateInfo es, PokeChain es, MonadResource m) =>
[ByteString]
-> [ByteString]
-> [ByteString]
-> [ByteString]
-> InstanceCreateInfo es
-> m Instance
createInstanceWithExtensions
      [ByteString]
requiredLayers
      ("VK_LAYER_KHRONOS_validation" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
optionalLayers)
      (ByteString
forall a. (Eq a, IsString a) => a
EXT_DEBUG_UTILS_EXTENSION_NAME ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
requiredExtensions)
      (ByteString
forall a. (Eq a, IsString a) => a
EXT_VALIDATION_FEATURES_EXTENSION_NAME ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
optionalExtensions)
      InstanceCreateInfo
  (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo'
    (ReleaseKey, DebugUtilsMessengerEXT)
_ <- Instance
-> DebugUtilsMessengerCreateInfoEXT
-> Maybe AllocationCallbacks
-> (IO DebugUtilsMessengerEXT
    -> (DebugUtilsMessengerEXT -> IO ())
    -> m (ReleaseKey, DebugUtilsMessengerEXT))
-> m (ReleaseKey, DebugUtilsMessengerEXT)
forall (io :: * -> *) r.
MonadIO io =>
Instance
-> DebugUtilsMessengerCreateInfoEXT
-> Maybe AllocationCallbacks
-> (io DebugUtilsMessengerEXT
    -> (DebugUtilsMessengerEXT -> io ()) -> r)
-> r
withDebugUtilsMessengerEXT Instance
inst
                                    DebugUtilsMessengerCreateInfoEXT
debugMessengerCreateInfo
                                    Maybe AllocationCallbacks
forall a. Maybe a
Nothing
                                    IO DebugUtilsMessengerEXT
-> (DebugUtilsMessengerEXT -> IO ())
-> m (ReleaseKey, DebugUtilsMessengerEXT)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
    Instance -> m Instance
forall (f :: * -> *) a. Applicative f => a -> f a
pure Instance
inst

-- | Create an 'Instance' with some layers and extensions, the layers and
-- extensions will be added to the provided 'InstanceCreateInfo'.
--
-- Will throw an 'IOError in the case of missing layers or extensions. Details
-- on missing layers and extensions will be reported in stderr.
createInstanceWithExtensions
  :: forall es m
   . (Extendss InstanceCreateInfo es, PokeChain es, MonadResource m)
  => [ByteString]
  -- ^ Required layers
  -> [ByteString]
  -- ^ Optional layers
  -> [ByteString]
  -- ^ Required extensions
  -> [ByteString]
  -- ^ Optional extensions
  -> InstanceCreateInfo es
  -> m Instance
createInstanceWithExtensions :: [ByteString]
-> [ByteString]
-> [ByteString]
-> [ByteString]
-> InstanceCreateInfo es
-> m Instance
createInstanceWithExtensions requiredLayers :: [ByteString]
requiredLayers optionalLayers :: [ByteString]
optionalLayers requiredExtensions :: [ByteString]
requiredExtensions optionalExtensions :: [ByteString]
optionalExtensions instanceCreateInfo :: InstanceCreateInfo es
instanceCreateInfo
  = do
    --
    -- First get the layers, they're needed to get the list of supported
    -- extensions, as some of them may only be present in layers.
    --
    [ByteString]
availableLayerNames <-
      Vector ByteString -> [ByteString]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector ByteString -> [ByteString])
-> ((Result, Vector LayerProperties) -> Vector ByteString)
-> (Result, Vector LayerProperties)
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LayerProperties -> ByteString)
-> Vector LayerProperties -> Vector ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LayerProperties -> ByteString
layerName (Vector LayerProperties -> Vector ByteString)
-> ((Result, Vector LayerProperties) -> Vector LayerProperties)
-> (Result, Vector LayerProperties)
-> Vector ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result, Vector LayerProperties) -> Vector LayerProperties
forall a b. (a, b) -> b
snd ((Result, Vector LayerProperties) -> [ByteString])
-> m (Result, Vector LayerProperties) -> m [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Result, Vector LayerProperties)
forall (io :: * -> *).
MonadIO io =>
io (Result, Vector LayerProperties)
enumerateInstanceLayerProperties
    [ByteString]
layers <- String
-> [ByteString] -> [ByteString] -> [ByteString] -> m [ByteString]
forall a (m :: * -> *).
(Show a, Eq a, MonadIO m) =>
String -> [a] -> [a] -> [a] -> m [a]
partitionOptReqIO "layer"
                                [ByteString]
availableLayerNames
                                [ByteString]
optionalLayers
                                [ByteString]
requiredLayers

    -- Run 'enumerateInstanceExtensionProperties' once for the instance itself,
    -- and once for each layer and collect the results.
    [ByteString]
availableExtensionNames <- [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ByteString]] -> [ByteString])
-> m [[ByteString]] -> m [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (("layerName" ::: Maybe ByteString) -> m [ByteString])
-> ["layerName" ::: Maybe ByteString] -> m [[ByteString]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
      ( ((Result, Vector ExtensionProperties) -> [ByteString])
-> m (Result, Vector ExtensionProperties) -> m [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vector ByteString -> [ByteString]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector ByteString -> [ByteString])
-> ((Result, Vector ExtensionProperties) -> Vector ByteString)
-> (Result, Vector ExtensionProperties)
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtensionProperties -> ByteString)
-> Vector ExtensionProperties -> Vector ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtensionProperties -> ByteString
extensionName (Vector ExtensionProperties -> Vector ByteString)
-> ((Result, Vector ExtensionProperties)
    -> Vector ExtensionProperties)
-> (Result, Vector ExtensionProperties)
-> Vector ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result, Vector ExtensionProperties) -> Vector ExtensionProperties
forall a b. (a, b) -> b
snd)
      (m (Result, Vector ExtensionProperties) -> m [ByteString])
-> (("layerName" ::: Maybe ByteString)
    -> m (Result, Vector ExtensionProperties))
-> ("layerName" ::: Maybe ByteString)
-> m [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("layerName" ::: Maybe ByteString)
-> m (Result, Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
("layerName" ::: Maybe ByteString)
-> io (Result, Vector ExtensionProperties)
enumerateInstanceExtensionProperties
      )
      ("layerName" ::: Maybe ByteString
forall a. Maybe a
Nothing ("layerName" ::: Maybe ByteString)
-> ["layerName" ::: Maybe ByteString]
-> ["layerName" ::: Maybe ByteString]
forall a. a -> [a] -> [a]
: (ByteString -> "layerName" ::: Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> "layerName" ::: Maybe ByteString)
-> [ByteString] -> ["layerName" ::: Maybe ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
layers))
    [ByteString]
extensions <- String
-> [ByteString] -> [ByteString] -> [ByteString] -> m [ByteString]
forall a (m :: * -> *).
(Show a, Eq a, MonadIO m) =>
String -> [a] -> [a] -> [a] -> m [a]
partitionOptReqIO "instance extension"
                                    [ByteString]
availableExtensionNames
                                    [ByteString]
optionalExtensions
                                    [ByteString]
requiredExtensions

    let
      instanceCreateInfo' :: InstanceCreateInfo es
      instanceCreateInfo' :: InstanceCreateInfo es
instanceCreateInfo' = InstanceCreateInfo es
instanceCreateInfo
        { $sel:enabledLayerNames:InstanceCreateInfo :: Vector ByteString
enabledLayerNames     =
          InstanceCreateInfo es -> Vector ByteString
forall (es :: [*]). InstanceCreateInfo es -> Vector ByteString
enabledLayerNames (InstanceCreateInfo es
instanceCreateInfo :: InstanceCreateInfo es)
            Vector ByteString -> Vector ByteString -> Vector ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Vector ByteString
forall a. [a] -> Vector a
V.fromList [ByteString]
layers
        , $sel:enabledExtensionNames:InstanceCreateInfo :: Vector ByteString
enabledExtensionNames =
          InstanceCreateInfo es -> Vector ByteString
forall (es :: [*]). InstanceCreateInfo es -> Vector ByteString
enabledExtensionNames (InstanceCreateInfo es
instanceCreateInfo :: InstanceCreateInfo es)
            Vector ByteString -> Vector ByteString -> Vector ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Vector ByteString
forall a. [a] -> Vector a
V.fromList [ByteString]
extensions
        }
    (_, inst :: Instance
inst) <- InstanceCreateInfo es
-> Maybe AllocationCallbacks
-> (IO Instance -> (Instance -> IO ()) -> m (ReleaseKey, Instance))
-> m (ReleaseKey, Instance)
forall (a :: [*]) (io :: * -> *) r.
(Extendss InstanceCreateInfo a, PokeChain a, MonadIO io) =>
InstanceCreateInfo a
-> Maybe AllocationCallbacks
-> (io Instance -> (Instance -> io ()) -> r)
-> r
withInstance InstanceCreateInfo es
instanceCreateInfo' Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO Instance -> (Instance -> IO ()) -> m (ReleaseKey, Instance)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
    Instance -> m Instance
forall (f :: * -> *) a. Applicative f => a -> f a
pure Instance
inst

----------------------------------------------------------------
-- * Physical device selection
----------------------------------------------------------------

-- | Get a single 'PhysicalDevice' deciding with a scoring function
--
-- Pass a function which will extract any required values from a device in the
-- spirit of parse-don't validate. Also provide a function to compare these
-- results for sorting multiple devices.
--
-- For example the result function could return a tuple of device memory and
-- the compute queue family index, and the scoring function could be 'fst' to
-- select devices based on their memory capacity.
--
-- If no devices are deemed suitable then an 'IOError' is thrown.
pickPhysicalDevice
  :: (MonadIO m, Ord b)
  => Instance
  -> (PhysicalDevice -> m (Maybe a))
  -- ^ Some result for a PhysicalDevice, Nothing if it is not to be chosen.
  -> (a -> b)
  -- ^ Scoring function to rate this result
  -> m (a, PhysicalDevice)
  -- ^ The score and the device
pickPhysicalDevice :: Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (a, PhysicalDevice)
pickPhysicalDevice inst :: Instance
inst devInfo :: PhysicalDevice -> m (Maybe a)
devInfo score :: a -> b
score = do
  (_, devs :: "physicalDevices" ::: Vector PhysicalDevice
devs) <- Instance -> m (Result, "physicalDevices" ::: Vector PhysicalDevice)
forall (io :: * -> *).
MonadIO io =>
Instance
-> io (Result, "physicalDevices" ::: Vector PhysicalDevice)
enumeratePhysicalDevices Instance
inst
  [(a, PhysicalDevice)]
infos    <- [Maybe (a, PhysicalDevice)] -> [(a, PhysicalDevice)]
forall a. [Maybe a] -> [a]
catMaybes
    ([Maybe (a, PhysicalDevice)] -> [(a, PhysicalDevice)])
-> m [Maybe (a, PhysicalDevice)] -> m [(a, PhysicalDevice)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m (Maybe (a, PhysicalDevice))] -> m [Maybe (a, PhysicalDevice)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ (a -> (a, PhysicalDevice)) -> Maybe a -> Maybe (a, PhysicalDevice)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, PhysicalDevice
d) (Maybe a -> Maybe (a, PhysicalDevice))
-> m (Maybe a) -> m (Maybe (a, PhysicalDevice))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m (Maybe a)
devInfo PhysicalDevice
d | PhysicalDevice
d <- ("physicalDevices" ::: Vector PhysicalDevice) -> [PhysicalDevice]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList "physicalDevices" ::: Vector PhysicalDevice
devs ]
  case ((a, PhysicalDevice) -> (a, PhysicalDevice) -> Ordering)
-> [(a, PhysicalDevice)] -> Maybe (a, PhysicalDevice)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> Maybe a
maximumByMay (((a, PhysicalDevice) -> b)
-> (a, PhysicalDevice) -> (a, PhysicalDevice) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a -> b
score(a -> b) -> ((a, PhysicalDevice) -> a) -> (a, PhysicalDevice) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, PhysicalDevice) -> a
forall a b. (a, b) -> a
fst)) [(a, PhysicalDevice)]
infos of
    Nothing -> IO (a, PhysicalDevice) -> m (a, PhysicalDevice)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, PhysicalDevice) -> m (a, PhysicalDevice))
-> IO (a, PhysicalDevice) -> m (a, PhysicalDevice)
forall a b. (a -> b) -> a -> b
$ String -> IO (a, PhysicalDevice)
forall a. String -> IO a
noSuchThing "Unable to find appropriate PhysicalDevice"
    Just d :: (a, PhysicalDevice)
d  -> (a, PhysicalDevice) -> m (a, PhysicalDevice)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, PhysicalDevice)
d

-- | Extract the name of a 'PhysicalDevice' with 'getPhysicalDeviceProperties'
physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text
physicalDeviceName :: PhysicalDevice -> m Text
physicalDeviceName =
  (PhysicalDeviceProperties -> Text)
-> m PhysicalDeviceProperties -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (PhysicalDeviceProperties -> ByteString)
-> PhysicalDeviceProperties
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhysicalDeviceProperties -> ByteString
deviceName) (m PhysicalDeviceProperties -> m Text)
-> (PhysicalDevice -> m PhysicalDeviceProperties)
-> PhysicalDevice
-> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhysicalDevice -> m PhysicalDeviceProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceProperties
getPhysicalDeviceProperties

----------------------------------------------------------------
-- * Device initialization
----------------------------------------------------------------

-- | Create a 'Device' with some extensions, the extensions will be added to
-- the provided 'DeviceCreateInfo'.
--
-- Will throw an 'IOError in the case of missing extensions. Missing extensions
-- will be listed on stderr.
createDeviceWithExtensions
  :: forall es m
   . (Extendss DeviceCreateInfo es, PokeChain es, MonadResource m)
  => PhysicalDevice
  -> [ByteString]
  -- ^ Required extensions
  -> [ByteString]
  -- ^ Optional extensions
  -> DeviceCreateInfo es
  -> m Device
createDeviceWithExtensions :: PhysicalDevice
-> [ByteString] -> [ByteString] -> DeviceCreateInfo es -> m Device
createDeviceWithExtensions phys :: PhysicalDevice
phys requiredExtensions :: [ByteString]
requiredExtensions optionalExtensions :: [ByteString]
optionalExtensions deviceCreateInfo :: DeviceCreateInfo es
deviceCreateInfo
  = do
    Vector ByteString
availableExtensionNames <-
      (ExtensionProperties -> ByteString)
-> Vector ExtensionProperties -> Vector ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtensionProperties -> ByteString
extensionName
      (Vector ExtensionProperties -> Vector ByteString)
-> ((Result, Vector ExtensionProperties)
    -> Vector ExtensionProperties)
-> (Result, Vector ExtensionProperties)
-> Vector ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   (Result, Vector ExtensionProperties) -> Vector ExtensionProperties
forall a b. (a, b) -> b
snd
      ((Result, Vector ExtensionProperties) -> Vector ByteString)
-> m (Result, Vector ExtensionProperties) -> m (Vector ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> m (Result, Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> io (Result, Vector ExtensionProperties)
enumerateDeviceExtensionProperties PhysicalDevice
phys "layerName" ::: Maybe ByteString
forall a. Maybe a
Nothing
    [ByteString]
extensions <- String
-> [ByteString] -> [ByteString] -> [ByteString] -> m [ByteString]
forall a (m :: * -> *).
(Show a, Eq a, MonadIO m) =>
String -> [a] -> [a] -> [a] -> m [a]
partitionOptReqIO "device extension"
                                    (Vector ByteString -> [ByteString]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector ByteString
availableExtensionNames)
                                    [ByteString]
requiredExtensions
                                    [ByteString]
optionalExtensions

    let
      deviceCreateInfo' :: DeviceCreateInfo es
      deviceCreateInfo' :: DeviceCreateInfo es
deviceCreateInfo' = DeviceCreateInfo es
deviceCreateInfo
        { $sel:enabledExtensionNames:DeviceCreateInfo :: Vector ByteString
enabledExtensionNames =
          DeviceCreateInfo es -> Vector ByteString
forall (es :: [*]). DeviceCreateInfo es -> Vector ByteString
enabledExtensionNames (DeviceCreateInfo es
deviceCreateInfo :: DeviceCreateInfo es)
            Vector ByteString -> Vector ByteString -> Vector ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Vector ByteString
forall a. [a] -> Vector a
V.fromList [ByteString]
extensions
        }

    (_, dev :: Device
dev) <- PhysicalDevice
-> DeviceCreateInfo es
-> Maybe AllocationCallbacks
-> (IO Device -> (Device -> IO ()) -> m (ReleaseKey, Device))
-> m (ReleaseKey, Device)
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
deviceCreateInfo' Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO Device -> (Device -> IO ()) -> m (ReleaseKey, Device)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
    Device -> m Device
forall (f :: * -> *) a. Applicative f => a -> f a
pure Device
dev

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

noSuchThing :: String -> IO a
noSuchThing :: String -> IO a
noSuchThing message :: String
message =
  IOException -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOException -> IO a) -> IOException -> IO a
forall a b. (a -> b) -> a -> b
$ Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
NoSuchThing "" String
message Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a
maximumByMay :: (a -> a -> Ordering) -> t a -> Maybe a
maximumByMay f :: a -> a -> Ordering
f xs :: t a
xs = if t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just ((a -> a -> Ordering) -> t a -> a
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy a -> a -> Ordering
f t a
xs)