{-# LANGUAGE CPP #-}

module Engine.Setup where

import RIO

import GHC.Clock (getMonotonicTimeNSec)
import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Core12 (pattern API_VERSION_1_2)
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_portability_enumeration qualified as Khr
import Vulkan.Extensions.VK_KHR_surface qualified as Khr
import Vulkan.Requirement (InstanceRequirement(..))
import Vulkan.Utils.Initialization (createInstanceFromRequirements)
import Vulkan.Utils.Requirements (checkInstanceRequirements, requirementReport)
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Vulkan.Zero (zero)
import VulkanMemoryAllocator qualified as VMA

#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"

  let
    iReqs :: [InstanceRequirement]
iReqs = InstanceRequirement
portabilityEnum InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: InstanceRequirement
deviceProps InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: InstanceRequirement
debugUtils InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: [InstanceRequirement]
windowReqs
    oReqs :: [a]
oReqs = []
    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
      }
    instanceCI :: InstanceCreateInfo '[]
instanceCI = InstanceCreateInfo '[]
forall a. Zero a => a
zero
      { Vk.applicationInfo = Just appInfo
      , Vk.flags = Vk.INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR
      }
  (Maybe (InstanceCreateInfo '[])
instanceCI', [RequirementResult]
reqResult, [RequirementResult]
optResult) <- [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO
     env
     (Maybe (InstanceCreateInfo '[]), [RequirementResult],
      [RequirementResult])
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]
iReqs [InstanceRequirement]
forall a. [a]
oReqs InstanceCreateInfo '[]
instanceCI
  let report :: Maybe Utf8Builder
report = (String -> Utf8Builder) -> Maybe String -> Maybe Utf8Builder
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Maybe String -> Maybe Utf8Builder)
-> Maybe String -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$ [RequirementResult] -> [RequirementResult] -> Maybe String
forall (r :: * -> *) (o :: * -> *).
(Foldable r, Foldable o) =>
r RequirementResult -> o RequirementResult -> Maybe String
requirementReport [RequirementResult]
reqResult [RequirementResult]
optResult
  Instance
ghInstance <- case Maybe (InstanceCreateInfo '[])
instanceCI' of
    Maybe (InstanceCreateInfo '[])
Nothing -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Instance check failed"
      (Utf8Builder -> RIO env ()) -> Maybe Utf8Builder -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Maybe Utf8Builder
report
      [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO env Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements [InstanceRequirement]
iReqs [InstanceRequirement]
forall a. [a]
oReqs InstanceCreateInfo '[]
instanceCI
    Just InstanceCreateInfo '[]
ci -> do
      (Utf8Builder -> RIO env ()) -> Maybe Utf8Builder -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Maybe Utf8Builder
report
      [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO env Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements [InstanceRequirement]
iReqs [InstanceRequirement]
forall a. [a]
oReqs InstanceCreateInfo '[]
ci

  Options
-> Window
-> Instance
-> RIO env (GlobalHandles, Maybe SwapchainResources)
forall env.
(HasLogFunc env, MonadResource (RIO env)) =>
Options
-> Window
-> Instance
-> RIO env (GlobalHandles, Maybe SwapchainResources)
setupWith Options
ghOptions Window
ghWindow Instance
ghInstance

setupWith
  :: ( HasLogFunc env
     , MonadResource (RIO env)
     )
  => Options
  -> Window.Window
  -> Vk.Instance
  -> RIO env (GlobalHandles, Maybe SwapchainResources)
setupWith :: forall env.
(HasLogFunc env, MonadResource (RIO env)) =>
Options
-> Window
-> Instance
-> RIO env (GlobalHandles, Maybe SwapchainResources)
setupWith Options
ghOptions Window
ghWindow Instance
ghInstance = do
  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
      { VMA.physicalDevice  = Vk.physicalDeviceHandle ghPhysicalDevice
      , VMA.device          = Vk.deviceHandle ghDevice
      , VMA.instance'       = Vk.instanceHandle ghInstance
      , VMA.vulkanFunctions = Just $ vmaVulkanFunctions ghDevice 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
  Size
size <- IO Size -> RIO env Size
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Window -> IO Size
Window.getSize Window
ghWindow)
  Var Size
ghWindowSize <- Size -> RIO env (Var Size)
forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar Size
size

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

  Word64
ghMonotonicStart <- IO Word64 -> RIO env Word64
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec

  pure (GlobalHandles{Word64
Window
Allocator
Var Extent2D
Var Size
StageSwitchVar
Device
Instance
PhysicalDevice
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
ghWindowSize :: Var Size
ghStageSwitch :: StageSwitchVar
ghMonotonicStart :: Word64
$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:ghWindowSize:GlobalHandles :: Var Size
$sel:ghStageSwitch:GlobalHandles :: StageSwitchVar
$sel:ghMonotonicStart:GlobalHandles :: Word64
..}, 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
    { VMA.vkGetInstanceProcAddr =
        castFunPtr $ VkDynamic.pVkGetInstanceProcAddr instanceCmds
    , VMA.vkGetDeviceProcAddr =
        castFunPtr $ VkDynamic.pVkGetDeviceProcAddr 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

  let
    iReqs :: [InstanceRequirement]
iReqs = InstanceRequirement
portabilityEnum InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: InstanceRequirement
deviceProps InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: InstanceRequirement
debugUtils InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: [InstanceRequirement]
headlessReqs
    oReqs :: [a]
oReqs = []
    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
      }
    instanceCI :: InstanceCreateInfo '[]
instanceCI = InstanceCreateInfo '[]
forall a. Zero a => a
zero
      { Vk.applicationInfo = Just appInfo
      , Vk.flags = Vk.INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR
      }

  (Maybe (InstanceCreateInfo '[])
instanceCI', [RequirementResult]
reqResult, [RequirementResult]
optResult) <- [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO
     env
     (Maybe (InstanceCreateInfo '[]), [RequirementResult],
      [RequirementResult])
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]
iReqs [InstanceRequirement]
forall a. [a]
oReqs InstanceCreateInfo '[]
instanceCI
  let report :: Maybe Utf8Builder
report = (String -> Utf8Builder) -> Maybe String -> Maybe Utf8Builder
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Maybe String -> Maybe Utf8Builder)
-> Maybe String -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$ [RequirementResult] -> [RequirementResult] -> Maybe String
forall (r :: * -> *) (o :: * -> *).
(Foldable r, Foldable o) =>
r RequirementResult -> o RequirementResult -> Maybe String
requirementReport [RequirementResult]
reqResult [RequirementResult]
optResult
  Instance
hInstance <- case Maybe (InstanceCreateInfo '[])
instanceCI' of
    Maybe (InstanceCreateInfo '[])
Nothing -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Instance check failed"
      (Utf8Builder -> RIO env ()) -> Maybe Utf8Builder -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Maybe Utf8Builder
report
      [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO env Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements [InstanceRequirement]
iReqs [InstanceRequirement]
forall a. [a]
oReqs InstanceCreateInfo '[]
instanceCI
    Just InstanceCreateInfo '[]
ci -> do
      (Utf8Builder -> RIO env ()) -> Maybe Utf8Builder -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Maybe Utf8Builder
report
      [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO env Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements [InstanceRequirement]
iReqs [InstanceRequirement]
forall a. [a]
oReqs InstanceCreateInfo '[]
ci

  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
      { VMA.physicalDevice  = Vk.physicalDeviceHandle hPhysicalDevice
      , VMA.device          = Vk.deviceHandle hDevice
      , VMA.instance'       = Vk.instanceHandle hInstance
      , VMA.vulkanFunctions = Just $ vmaVulkanFunctions hDevice 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
Device
Instance
PhysicalDevice
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

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

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
  ]

-- deriving instance Show InstanceRequirement