{-# LANGUAGE CPP #-}

module Engine.Setup where

import RIO

import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Extensions.VK_EXT_debug_utils qualified as Ext
import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 qualified as Khr
import Vulkan.Extensions.VK_KHR_surface qualified as Khr
import Vulkan.Requirement (InstanceRequirement(..))
import Vulkan.Utils.Initialization (createInstanceFromRequirements)
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Vulkan.Zero (zero)
import VulkanMemoryAllocator qualified as VMA
import Vulkan.Core12 (pattern API_VERSION_1_2)

#if MIN_VERSION_vulkan(3,15,0)
import Foreign.Ptr (castFunPtr)
import Vulkan.Dynamic qualified as VkDynamic
#endif

import Engine.Setup.Device (allocatePhysical, allocateLogical)
import Engine.Setup.Window qualified as Window
import Engine.Types (GlobalHandles(..))
import Engine.Types.Options (Options(..))
import Engine.Vulkan.Swapchain (SwapchainResources)
import Engine.Vulkan.Types (PhysicalDeviceInfo(..))
import Engine.Vulkan.Types qualified as Vulkan
import Engine.Worker qualified as Worker
import Engine.StageSwitch (newStageSwitchVar)

setup
  :: ( HasLogFunc env
     , MonadResource (RIO env)
     )
  => Options -> RIO env (GlobalHandles, Maybe SwapchainResources)
setup :: forall env.
(HasLogFunc env, MonadResource (RIO env)) =>
Options -> RIO env (GlobalHandles, Maybe SwapchainResources)
setup Options
ghOptions = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Options -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Options
ghOptions

  ([InstanceRequirement]
windowReqs, Window
ghWindow) <- Bool
-> Maybe (Int, Int)
-> Natural
-> SizePicker
-> Text
-> RIO env ([InstanceRequirement], Window)
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Bool
-> Maybe (Int, Int)
-> Natural
-> SizePicker
-> Text
-> m ([InstanceRequirement], Window)
Window.allocate
    (Options -> Bool
optionsFullscreen Options
ghOptions)
    (Options -> Maybe (Int, Int)
optionsSize Options
ghOptions)
    (Options -> Natural
optionsDisplay Options
ghOptions)
    SizePicker
Window.pickLargest
    Text
"Keid Engine"

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating instance"
  let
    appInfo :: ApplicationInfo
appInfo = Vk.ApplicationInfo
      { $sel:apiVersion:ApplicationInfo :: Word32
apiVersion = Word32
API_VERSION_1_2
      , $sel:applicationName:ApplicationInfo :: Maybe ByteString
applicationName = Maybe ByteString
forall a. Maybe a
Nothing
      , $sel:applicationVersion:ApplicationInfo :: Word32
applicationVersion = Word32
0
      , $sel:engineName:ApplicationInfo :: Maybe ByteString
engineName = Maybe ByteString
forall a. Maybe a
Nothing
      , $sel:engineVersion:ApplicationInfo :: Word32
engineVersion = Word32
0
      }
  Instance
ghInstance <- [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO env Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements
    (InstanceRequirement
deviceProps InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: InstanceRequirement
debugUtils InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: [InstanceRequirement]
windowReqs)
    [InstanceRequirement]
forall a. Monoid a => a
mempty
    (InstanceCreateInfo '[]
forall a. Zero a => a
zero { $sel:applicationInfo:InstanceCreateInfo :: Maybe ApplicationInfo
Vk.applicationInfo = ApplicationInfo -> Maybe ApplicationInfo
forall a. a -> Maybe a
Just ApplicationInfo
appInfo })

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating surface"
  (ReleaseKey
_surfaceKey, SurfaceKHR
ghSurface) <- Window -> Instance -> RIO env (ReleaseKey, SurfaceKHR)
forall (m :: * -> *).
MonadResource m =>
Window -> Instance -> m (ReleaseKey, SurfaceKHR)
Window.allocateSurface Window
ghWindow Instance
ghInstance

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating physical device"
  (PhysicalDeviceInfo
ghPhysicalDeviceInfo, PhysicalDevice
ghPhysicalDevice) <- Instance
-> Maybe SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> RIO env (PhysicalDeviceInfo, PhysicalDevice)
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadThrow m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Instance
-> Maybe SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> m (PhysicalDeviceInfo, PhysicalDevice)
allocatePhysical
    Instance
ghInstance
    (SurfaceKHR -> Maybe SurfaceKHR
forall a. a -> Maybe a
Just SurfaceKHR
ghSurface)
    PhysicalDeviceInfo -> Word64
pdiTotalMemory

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating logical device"
  Device
ghDevice <- PhysicalDeviceInfo -> PhysicalDevice -> RIO env Device
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
PhysicalDeviceInfo -> PhysicalDevice -> m Device
allocateLogical PhysicalDeviceInfo
ghPhysicalDeviceInfo PhysicalDevice
ghPhysicalDevice

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating VMA"
  let
    allocatorCI :: VMA.AllocatorCreateInfo
    allocatorCI :: AllocatorCreateInfo
allocatorCI = AllocatorCreateInfo
forall a. Zero a => a
zero
      { $sel:physicalDevice:AllocatorCreateInfo :: Ptr PhysicalDevice_T
VMA.physicalDevice  = PhysicalDevice -> Ptr PhysicalDevice_T
Vk.physicalDeviceHandle PhysicalDevice
ghPhysicalDevice
      , $sel:device:AllocatorCreateInfo :: Ptr Device_T
VMA.device          = Device -> Ptr Device_T
Vk.deviceHandle Device
ghDevice
      , $sel:instance':AllocatorCreateInfo :: Ptr Instance_T
VMA.instance'       = Instance -> Ptr Instance_T
Vk.instanceHandle Instance
ghInstance
      , $sel:vulkanFunctions:AllocatorCreateInfo :: Maybe VulkanFunctions
VMA.vulkanFunctions = VulkanFunctions -> Maybe VulkanFunctions
forall a. a -> Maybe a
Just (VulkanFunctions -> Maybe VulkanFunctions)
-> VulkanFunctions -> Maybe VulkanFunctions
forall a b. (a -> b) -> a -> b
$ Device -> Instance -> VulkanFunctions
vmaVulkanFunctions Device
ghDevice Instance
ghInstance
      }
  (ReleaseKey
_vmaKey, Allocator
ghAllocator) <- AllocatorCreateInfo
-> (IO Allocator
    -> (Allocator -> IO ()) -> RIO env (ReleaseKey, Allocator))
-> RIO env (ReleaseKey, Allocator)
forall (io :: * -> *) r.
MonadIO io =>
AllocatorCreateInfo
-> (io Allocator -> (Allocator -> io ()) -> r) -> r
VMA.withAllocator AllocatorCreateInfo
allocatorCI IO Allocator
-> (Allocator -> IO ()) -> RIO env (ReleaseKey, Allocator)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  RIO env () -> RIO env (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing VMA") RIO env (IO ())
-> (IO () -> RIO env ReleaseKey) -> RIO env ReleaseKey
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> RIO env ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register

  Queues (QueueFamilyIndex, Queue)
ghQueues <- IO (Queues (QueueFamilyIndex, Queue))
-> RIO env (Queues (QueueFamilyIndex, Queue))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Queues (QueueFamilyIndex, Queue))
 -> RIO env (Queues (QueueFamilyIndex, Queue)))
-> IO (Queues (QueueFamilyIndex, Queue))
-> RIO env (Queues (QueueFamilyIndex, Queue))
forall a b. (a -> b) -> a -> b
$ PhysicalDeviceInfo
-> Device -> IO (Queues (QueueFamilyIndex, Queue))
pdiGetQueues PhysicalDeviceInfo
ghPhysicalDeviceInfo Device
ghDevice
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Got command queues: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Queues Word32 -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (((QueueFamilyIndex, Queue) -> Word32)
-> Queues (QueueFamilyIndex, Queue) -> Queues Word32
forall a b. (a -> b) -> Queues a -> Queues b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QueueFamilyIndex -> Word32
unQueueFamilyIndex (QueueFamilyIndex -> Word32)
-> ((QueueFamilyIndex, Queue) -> QueueFamilyIndex)
-> (QueueFamilyIndex, Queue)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueueFamilyIndex, Queue) -> QueueFamilyIndex
forall a b. (a, b) -> a
fst) Queues (QueueFamilyIndex, Queue)
ghQueues)

  Extent2D
screen <- IO Extent2D -> RIO env Extent2D
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Extent2D -> RIO env Extent2D)
-> IO Extent2D -> RIO env Extent2D
forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
ghWindow
  Var Extent2D
ghScreenVar <- Extent2D -> RIO env (Var Extent2D)
forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Extent2D
screen

  StageSwitchVar
ghStageSwitch <- RIO env StageSwitchVar
forall (m :: * -> *). MonadIO m => m StageSwitchVar
newStageSwitchVar

  pure (GlobalHandles{Window
Allocator
Var Extent2D
StageSwitchVar
PhysicalDevice
Instance
Device
SurfaceKHR
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
Options
ghOptions :: Options
ghWindow :: Window
ghInstance :: Instance
ghSurface :: SurfaceKHR
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghPhysicalDevice :: PhysicalDevice
ghDevice :: Device
ghAllocator :: Allocator
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghScreenVar :: Var Extent2D
ghStageSwitch :: StageSwitchVar
$sel:ghOptions:GlobalHandles :: Options
$sel:ghWindow:GlobalHandles :: Window
$sel:ghSurface:GlobalHandles :: SurfaceKHR
$sel:ghInstance:GlobalHandles :: Instance
$sel:ghPhysicalDevice:GlobalHandles :: PhysicalDevice
$sel:ghPhysicalDeviceInfo:GlobalHandles :: PhysicalDeviceInfo
$sel:ghDevice:GlobalHandles :: Device
$sel:ghAllocator:GlobalHandles :: Allocator
$sel:ghQueues:GlobalHandles :: Queues (QueueFamilyIndex, Queue)
$sel:ghScreenVar:GlobalHandles :: Var Extent2D
$sel:ghStageSwitch:GlobalHandles :: StageSwitchVar
..}, Maybe SwapchainResources
forall a. Maybe a
Nothing)

vmaVulkanFunctions
  :: Vk.Device
  -> Vk.Instance
  -> VMA.VulkanFunctions
#if MIN_VERSION_vulkan(3,15,0)
vmaVulkanFunctions :: Device -> Instance -> VulkanFunctions
vmaVulkanFunctions Vk.Device{DeviceCmds
deviceCmds :: DeviceCmds
$sel:deviceCmds:Device :: Device -> DeviceCmds
deviceCmds} Vk.Instance{InstanceCmds
instanceCmds :: InstanceCmds
$sel:instanceCmds:Instance :: Instance -> InstanceCmds
instanceCmds} =
  VulkanFunctions
forall a. Zero a => a
zero
    { $sel:vkGetInstanceProcAddr:VulkanFunctions :: PFN_vkGetInstanceProcAddr
VMA.vkGetInstanceProcAddr =
        FunPtr
  (Ptr Instance_T
   -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
-> PFN_vkGetInstanceProcAddr
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr
   (Ptr Instance_T
    -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
 -> PFN_vkGetInstanceProcAddr)
-> FunPtr
     (Ptr Instance_T
      -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
-> PFN_vkGetInstanceProcAddr
forall a b. (a -> b) -> a -> b
$ InstanceCmds
-> FunPtr
     (Ptr Instance_T
      -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
VkDynamic.pVkGetInstanceProcAddr InstanceCmds
instanceCmds
    , $sel:vkGetDeviceProcAddr:VulkanFunctions :: PFN_vkGetDeviceProcAddr
VMA.vkGetDeviceProcAddr =
        FunPtr
  (Ptr Device_T -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
-> PFN_vkGetDeviceProcAddr
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr
   (Ptr Device_T -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
 -> PFN_vkGetDeviceProcAddr)
-> FunPtr
     (Ptr Device_T -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
-> PFN_vkGetDeviceProcAddr
forall a b. (a -> b) -> a -> b
$ DeviceCmds
-> FunPtr
     (Ptr Device_T -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction)
VkDynamic.pVkGetDeviceProcAddr DeviceCmds
deviceCmds
    }
#else
vmaVulkanFunctions _device _instance = zero
#endif

setupHeadless
  :: ( HasLogFunc env
     , MonadResource (RIO env)
     )
  => Options
  -> RIO env Headless
setupHeadless :: forall env.
(HasLogFunc env, MonadResource (RIO env)) =>
Options -> RIO env Headless
setupHeadless Options
opts = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Options -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Options
opts

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating instance"
  Instance
hInstance <- [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO env Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements
    (InstanceRequirement
deviceProps InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: InstanceRequirement
debugUtils InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: [InstanceRequirement]
headlessReqs)
    [InstanceRequirement]
forall a. Monoid a => a
mempty
    InstanceCreateInfo '[]
forall a. Zero a => a
zero

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating physical device"
  (PhysicalDeviceInfo
hPhysicalDeviceInfo, PhysicalDevice
hPhysicalDevice) <- Instance
-> Maybe SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> RIO env (PhysicalDeviceInfo, PhysicalDevice)
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadThrow m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Instance
-> Maybe SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> m (PhysicalDeviceInfo, PhysicalDevice)
allocatePhysical
    Instance
hInstance
    Maybe SurfaceKHR
forall a. Maybe a
Nothing
    PhysicalDeviceInfo -> Word64
pdiTotalMemory

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating logical device"
  Device
hDevice <- PhysicalDeviceInfo -> PhysicalDevice -> RIO env Device
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
PhysicalDeviceInfo -> PhysicalDevice -> m Device
allocateLogical PhysicalDeviceInfo
hPhysicalDeviceInfo PhysicalDevice
hPhysicalDevice

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating VMA"
  let
    allocatorCI :: VMA.AllocatorCreateInfo
    allocatorCI :: AllocatorCreateInfo
allocatorCI = AllocatorCreateInfo
forall a. Zero a => a
zero
      { $sel:physicalDevice:AllocatorCreateInfo :: Ptr PhysicalDevice_T
VMA.physicalDevice  = PhysicalDevice -> Ptr PhysicalDevice_T
Vk.physicalDeviceHandle PhysicalDevice
hPhysicalDevice
      , $sel:device:AllocatorCreateInfo :: Ptr Device_T
VMA.device          = Device -> Ptr Device_T
Vk.deviceHandle Device
hDevice
      , $sel:instance':AllocatorCreateInfo :: Ptr Instance_T
VMA.instance'       = Instance -> Ptr Instance_T
Vk.instanceHandle Instance
hInstance
      , $sel:vulkanFunctions:AllocatorCreateInfo :: Maybe VulkanFunctions
VMA.vulkanFunctions = VulkanFunctions -> Maybe VulkanFunctions
forall a. a -> Maybe a
Just (VulkanFunctions -> Maybe VulkanFunctions)
-> VulkanFunctions -> Maybe VulkanFunctions
forall a b. (a -> b) -> a -> b
$ Device -> Instance -> VulkanFunctions
vmaVulkanFunctions Device
hDevice Instance
hInstance
      }
  (ReleaseKey
_vmaKey, Allocator
hAllocator) <- AllocatorCreateInfo
-> (IO Allocator
    -> (Allocator -> IO ()) -> RIO env (ReleaseKey, Allocator))
-> RIO env (ReleaseKey, Allocator)
forall (io :: * -> *) r.
MonadIO io =>
AllocatorCreateInfo
-> (io Allocator -> (Allocator -> io ()) -> r) -> r
VMA.withAllocator AllocatorCreateInfo
allocatorCI IO Allocator
-> (Allocator -> IO ()) -> RIO env (ReleaseKey, Allocator)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  RIO env () -> RIO env (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing VMA") RIO env (IO ())
-> (IO () -> RIO env ReleaseKey) -> RIO env ReleaseKey
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> RIO env ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register

  Queues (QueueFamilyIndex, Queue)
hQueues <- IO (Queues (QueueFamilyIndex, Queue))
-> RIO env (Queues (QueueFamilyIndex, Queue))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Queues (QueueFamilyIndex, Queue))
 -> RIO env (Queues (QueueFamilyIndex, Queue)))
-> IO (Queues (QueueFamilyIndex, Queue))
-> RIO env (Queues (QueueFamilyIndex, Queue))
forall a b. (a -> b) -> a -> b
$ PhysicalDeviceInfo
-> Device -> IO (Queues (QueueFamilyIndex, Queue))
pdiGetQueues PhysicalDeviceInfo
hPhysicalDeviceInfo Device
hDevice
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Got command queues: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Queues Word32 -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (((QueueFamilyIndex, Queue) -> Word32)
-> Queues (QueueFamilyIndex, Queue) -> Queues Word32
forall a b. (a -> b) -> Queues a -> Queues b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QueueFamilyIndex -> Word32
unQueueFamilyIndex (QueueFamilyIndex -> Word32)
-> ((QueueFamilyIndex, Queue) -> QueueFamilyIndex)
-> (QueueFamilyIndex, Queue)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueueFamilyIndex, Queue) -> QueueFamilyIndex
forall a b. (a, b) -> a
fst) Queues (QueueFamilyIndex, Queue)
hQueues)

  pure Headless{Allocator
PhysicalDevice
Instance
Device
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
hInstance :: Instance
hPhysicalDeviceInfo :: PhysicalDeviceInfo
hPhysicalDevice :: PhysicalDevice
hDevice :: Device
hAllocator :: Allocator
hQueues :: Queues (QueueFamilyIndex, Queue)
$sel:hInstance:Headless :: Instance
$sel:hPhysicalDeviceInfo:Headless :: PhysicalDeviceInfo
$sel:hPhysicalDevice:Headless :: PhysicalDevice
$sel:hDevice:Headless :: Device
$sel:hAllocator:Headless :: Allocator
$sel:hQueues:Headless :: Queues (QueueFamilyIndex, Queue)
..}

data Headless = Headless
  { Headless -> Instance
hInstance           :: Vk.Instance
  , Headless -> PhysicalDeviceInfo
hPhysicalDeviceInfo :: Vulkan.PhysicalDeviceInfo
  , Headless -> PhysicalDevice
hPhysicalDevice     :: Vk.PhysicalDevice
  , Headless -> Device
hDevice             :: Vk.Device
  , Headless -> Allocator
hAllocator          :: VMA.Allocator
  , Headless -> Queues (QueueFamilyIndex, Queue)
hQueues             :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue)
  }

instance Vulkan.HasVulkan Headless where
  getInstance :: Headless -> Instance
getInstance           = Headless -> Instance
hInstance
  getQueues :: Headless -> Queues (QueueFamilyIndex, Queue)
getQueues             = Headless -> Queues (QueueFamilyIndex, Queue)
hQueues
  getPhysicalDevice :: Headless -> PhysicalDevice
getPhysicalDevice     = Headless -> PhysicalDevice
hPhysicalDevice
  getPhysicalDeviceInfo :: Headless -> PhysicalDeviceInfo
getPhysicalDeviceInfo = Headless -> PhysicalDeviceInfo
hPhysicalDeviceInfo
  getDevice :: Headless -> Device
getDevice             = Headless -> Device
hDevice
  getAllocator :: Headless -> Allocator
getAllocator          = Headless -> Allocator
hAllocator

deviceProps :: InstanceRequirement
deviceProps :: InstanceRequirement
deviceProps = Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement
RequireInstanceExtension
  Maybe ByteString
forall a. Maybe a
Nothing
  ByteString
forall a. (Eq a, IsString a) => a
Khr.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME
  Word32
forall a. Bounded a => a
minBound

debugUtils :: InstanceRequirement
debugUtils :: InstanceRequirement
debugUtils = Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement
RequireInstanceExtension
  Maybe ByteString
forall a. Maybe a
Nothing
  ByteString
forall a. (Eq a, IsString a) => a
Ext.EXT_DEBUG_UTILS_EXTENSION_NAME
  Word32
forall a. Bounded a => a
minBound

headlessReqs :: [InstanceRequirement]
headlessReqs :: [InstanceRequirement]
headlessReqs =
  [ Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement
RequireInstanceExtension
      Maybe ByteString
forall a. Maybe a
Nothing
      ByteString
forall a. (Eq a, IsString a) => a
Khr.KHR_SURFACE_EXTENSION_NAME
      Word32
forall a. Bounded a => a
minBound
  ]