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

#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
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow Options
ghOptions

  ([InstanceRequirement]
windowReqs, Window
ghWindow) <- 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"

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

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

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating physical device"
  (PhysicalDeviceInfo
ghPhysicalDeviceInfo, PhysicalDevice
ghPhysicalDevice) <- 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
    (forall a. a -> Maybe a
Just SurfaceKHR
ghSurface)
    PhysicalDeviceInfo -> Word64
pdiTotalMemory

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

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating VMA"
  let
    allocatorCI :: VMA.AllocatorCreateInfo
    allocatorCI :: AllocatorCreateInfo
allocatorCI = 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Device -> Instance -> VulkanFunctions
vmaVulkanFunctions Device
ghDevice Instance
ghInstance
      }
  (ReleaseKey
_vmaKey, Allocator
ghAllocator) <- forall (io :: * -> *) r.
MonadIO io =>
AllocatorCreateInfo
-> (io Allocator -> (Allocator -> io ()) -> r) -> r
VMA.withAllocator AllocatorCreateInfo
allocatorCI forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing VMA") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register

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

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

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

  pure (GlobalHandles{Var Extent2D
StageSwitchVar
Window
Device
Instance
PhysicalDevice
SurfaceKHR
Allocator
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
Options
$sel:ghStageSwitch:GlobalHandles :: StageSwitchVar
$sel:ghScreenVar:GlobalHandles :: Var Extent2D
$sel:ghQueues:GlobalHandles :: Queues (QueueFamilyIndex, Queue)
$sel:ghAllocator:GlobalHandles :: Allocator
$sel:ghDevice:GlobalHandles :: Device
$sel:ghPhysicalDeviceInfo:GlobalHandles :: PhysicalDeviceInfo
$sel:ghPhysicalDevice:GlobalHandles :: PhysicalDevice
$sel:ghInstance:GlobalHandles :: Instance
$sel:ghSurface:GlobalHandles :: SurfaceKHR
$sel:ghWindow:GlobalHandles :: Window
$sel:ghOptions:GlobalHandles :: Options
ghStageSwitch :: StageSwitchVar
ghScreenVar :: Var Extent2D
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghAllocator :: Allocator
ghDevice :: Device
ghPhysicalDevice :: PhysicalDevice
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghSurface :: SurfaceKHR
ghInstance :: Instance
ghWindow :: Window
ghOptions :: Options
..}, 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
$sel:deviceCmds:Device :: Device -> DeviceCmds
deviceCmds :: DeviceCmds
deviceCmds} Vk.Instance{InstanceCmds
$sel:instanceCmds:Instance :: Instance -> InstanceCmds
instanceCmds :: InstanceCmds
instanceCmds} =
  forall a. Zero a => a
zero
    { $sel:vkGetInstanceProcAddr:VulkanFunctions :: PFN_vkGetInstanceProcAddr
VMA.vkGetInstanceProcAddr =
        forall a b. FunPtr a -> FunPtr b
castFunPtr 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 =
        forall a b. FunPtr a -> FunPtr b
castFunPtr 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
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow Options
opts

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

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating physical device"
  (PhysicalDeviceInfo
hPhysicalDeviceInfo, PhysicalDevice
hPhysicalDevice) <- 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
    forall a. Maybe a
Nothing
    PhysicalDeviceInfo -> Word64
pdiTotalMemory

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

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating VMA"
  let
    allocatorCI :: VMA.AllocatorCreateInfo
    allocatorCI :: AllocatorCreateInfo
allocatorCI = 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Device -> Instance -> VulkanFunctions
vmaVulkanFunctions Device
hDevice Instance
hInstance
      }
  (ReleaseKey
_vmaKey, Allocator
hAllocator) <- forall (io :: * -> *) r.
MonadIO io =>
AllocatorCreateInfo
-> (io Allocator -> (Allocator -> io ()) -> r) -> r
VMA.withAllocator AllocatorCreateInfo
allocatorCI forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing VMA") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register

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

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

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
  forall a. Maybe a
Nothing
  forall a. (Eq a, IsString a) => a
Khr.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME
  forall a. Bounded a => a
minBound

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

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