module Engine.Vulkan.Types
  ( MonadVulkan
  , HasVulkan(..)
  , getPipelineCache

  , HasSwapchain(..)
  , HasRenderPass(..)
  , RenderPass(..)

  , PhysicalDeviceInfo(..)
  , Queues(..)

  , DsLayouts
  , DsLayoutBindings

  , Bound(..)
  ) where

import RIO

import Data.Kind (Type)
import RIO.App (App(..))
import RIO.State (MonadState(..))
import UnliftIO.Resource (MonadResource)
import Vulkan.Core10 qualified as Vk
import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12
import Vulkan.NamedType ((:::))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import VulkanMemoryAllocator qualified as VMA

type MonadVulkan env m =
  ( MonadUnliftIO m
  , MonadReader env m
  , HasVulkan env
  )

-- | A class for Monads which can provide some Vulkan handles
class HasVulkan a where
  getInstance           :: a -> Vk.Instance
  getQueues             :: a -> Queues (QueueFamilyIndex, Vk.Queue)
  getPhysicalDevice     :: a -> Vk.PhysicalDevice
  getPhysicalDeviceInfo :: a -> PhysicalDeviceInfo
  getDevice             :: a -> Vk.Device
  getAllocator          :: a -> VMA.Allocator

instance HasVulkan env => HasVulkan (App env st) where
  getInstance           = getInstance . appEnv
  getQueues             = getQueues . appEnv
  getPhysicalDevice     = getPhysicalDevice . appEnv
  getPhysicalDeviceInfo = getPhysicalDeviceInfo . appEnv
  getDevice             = getDevice . appEnv
  getAllocator          = getAllocator . appEnv

instance (HasVulkan env) => HasVulkan (env, a) where
  getInstance           = getInstance . fst
  getQueues             = getQueues . fst
  getPhysicalDevice     = getPhysicalDevice . fst
  getPhysicalDeviceInfo = getPhysicalDeviceInfo . fst
  getDevice             = getDevice . fst
  getAllocator          = getAllocator . fst

-- TODO
getPipelineCache :: {- HasVulkan ctx => -} ctx -> Vk.PipelineCache
getPipelineCache _ctx = Vk.NULL_HANDLE

{- |
  The shape of all the queues we use for our program, parameterized over the
  queue type so we can use it with 'Vulkan.Utils.QueueAssignment.assignQueues'.
-}
data Queues q = Queues
  { qGraphics :: q
  , qTransfer :: q
  , qCompute  :: q
  }
  deriving (Show, Functor, Foldable, Traversable)

data PhysicalDeviceInfo = PhysicalDeviceInfo
  { pdiTotalMemory      :: Word64
  , pdiQueueCreateInfos :: Vector (Vk.DeviceQueueCreateInfo '[])
  , pdiName             :: Text
  , pdiProperties       :: Vk.PhysicalDeviceProperties
  , pdiGetQueues        :: Vk.Device -> IO (Queues (QueueFamilyIndex, Vk.Queue))
  }

class HasSwapchain a where
  getSurfaceExtent  :: a -> Vk.Extent2D
  getSurfaceFormat  :: a -> Vk.Format
  getDepthFormat    :: a -> Vk.Format
  getMultisample    :: a -> Vk.SampleCountFlagBits
  getAnisotropy     :: a -> "max sampler anisotropy" ::: Float
  getSwapchainViews :: a -> Vector Vk.ImageView
  getMinImageCount  :: a -> Word32
  getImageCount     :: a -> Word32

-- TODO: extract to a module
class HasRenderPass a where
  getFramebuffers        :: a -> Vector Vk.Framebuffer
  getRenderPass          :: a -> Vk.RenderPass
  getClearValues         :: a -> Vector Vk.ClearValue
  getRenderArea          :: a -> Vk.Rect2D

class RenderPass a where
  updateRenderpass
    :: ( HasLogFunc env
       , HasSwapchain swapchain
       , HasVulkan env
       , MonadResource (RIO env)
       )
    => swapchain
    -> a
    -> RIO env a
  updateRenderpass = const pure

  refcountRenderpass
    :: MonadResource (RIO env)
    => a
    -> RIO env ()

type DsLayoutBindings = [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)]
type DsLayouts = Vector Vk.DescriptorSetLayout

newtype Bound (dsl :: [Type]) vertices instances m a = Bound (m a)
  deriving stock (Foldable, Traversable, Functor)
  deriving newtype (Applicative, Monad, MonadIO, MonadUnliftIO)
  deriving newtype (MonadReader r, MonadState s)