{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module SDL.Video.Vulkan (
  -- * Vulkan types
  VkInstance, VkSurfaceKHR, VkGetInstanceProcAddrFunc,
  -- * Vulkan loader
  vkLoadLibrary, vkUnloadLibrary, vkGetVkGetInstanceProcAddr,
  -- * Vulkan surface
  vkGetInstanceExtensions, vkCreateSurface,
  -- * Querying for the drawable size
  vkGetDrawableSize
) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Foreign hiding (throwIf_, throwIfNeg_)
import Foreign.C.Types (CInt)
import Foreign.C.String (CString, withCString)
import SDL.Vect (V2 (V2))
import SDL.Internal.Exception (throwIf_, throwIfNeg_)
import SDL.Internal.Types (Window (Window))
import SDL.Raw.Types (VkInstance, VkSurfaceKHR, VkGetInstanceProcAddrFunc)
import qualified SDL.Raw as Raw

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif

-- | Dynamically load a Vulkan loader library.
--
-- If a filePath is 'Nothing', SDL will use the value of the environment variable
-- SDL_VULKAN_LIBRARY, if set, otherwise it loads the default Vulkan
-- loader library.
--
-- This function should be called after initializing the video driver
-- (i.e. 'SDL.Init.initialize' ['SDL.Init.InitVideo']), but before
-- creating any windows with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.
--
-- If no Vulkan loader library is loaded, analogue of 'vkLoadLibrary' 'Nothing'
-- will be automatically called by SDL C library upon creation of the first Vulkan window.
--
-- Throws 'SDL.Exception.SDLException' if there are no working Vulkan drivers installed.
vkLoadLibrary :: MonadIO m => Maybe FilePath -> m ()
vkLoadLibrary :: Maybe FilePath -> m ()
vkLoadLibrary = \case
    Nothing       -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO CInt -> IO ()) -> IO CInt -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO CInt -> IO ()
testNeg (IO CInt -> m ()) -> IO CInt -> m ()
forall a b. (a -> b) -> a -> b
$ CString -> IO CInt
forall (m :: * -> *). MonadIO m => CString -> m CInt
Raw.vkLoadLibrary CString
forall a. Ptr a
nullPtr
    Just filePath :: FilePath
filePath -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (CString -> IO ()) -> IO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filePath ((CString -> IO ()) -> m ()) -> (CString -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ IO CInt -> IO ()
testNeg (IO CInt -> IO ()) -> (CString -> IO CInt) -> CString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO CInt
forall (m :: * -> *). MonadIO m => CString -> m CInt
Raw.vkLoadLibrary
  where
    testNeg :: IO CInt -> IO ()
testNeg = Text -> Text -> IO CInt -> IO ()
forall (m :: * -> *) a.
(MonadIO m, Num a, Ord a) =>
Text -> Text -> m a -> m ()
throwIfNeg_ "SDL.Video.Vulkan.vkLoadLibrary" "SDL_Vulkan_LoadLibrary"

-- | Unload the Vulkan loader library previously loaded by 'vkLoadLibrary'.
--
-- Analogue of this function will be automatically called by SDL C library
-- after destruction of the last window with
-- 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.
vkUnloadLibrary :: MonadIO m => m ()
vkUnloadLibrary :: m ()
vkUnloadLibrary = m ()
forall (m :: * -> *). MonadIO m => m ()
Raw.vkUnloadLibrary

foreign import ccall "dynamic" mkVkGetInstanceProcAddrFunc ::
  FunPtr VkGetInstanceProcAddrFunc -> VkGetInstanceProcAddrFunc

-- | Get the vkGetInstanceProcAddr function, which can be used to obtain another Vulkan functions
-- (see <https://www.khronos.org/registry/vulkan/specs/1.0/man/html/vkGetInstanceProcAddr.html>).
--
-- The 'vkGetVkGetInstanceProcAddr' function should be called after either calling 'vkLoadLibrary'
-- function or creating first Vulkan window.
vkGetVkGetInstanceProcAddr :: (Functor m, MonadIO m) => m VkGetInstanceProcAddrFunc
vkGetVkGetInstanceProcAddr :: m VkGetInstanceProcAddrFunc
vkGetVkGetInstanceProcAddr = FunPtr VkGetInstanceProcAddrFunc -> VkGetInstanceProcAddrFunc
mkVkGetInstanceProcAddrFunc (FunPtr VkGetInstanceProcAddrFunc -> VkGetInstanceProcAddrFunc)
-> m (FunPtr VkGetInstanceProcAddrFunc)
-> m VkGetInstanceProcAddrFunc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (FunPtr VkGetInstanceProcAddrFunc)
forall (m :: * -> *).
MonadIO m =>
m (FunPtr VkGetInstanceProcAddrFunc)
Raw.vkGetVkGetInstanceProcAddr

-- | Get the names of the Vulkan instance extensions needed to create
-- a surface with 'vkCreateSurface'.
--
-- The extension names queried here must be enabled when calling vkCreateInstance
-- (see <https://www.khronos.org/registry/vulkan/specs/1.0/man/html/vkCreateInstance.html>),
-- otherwise 'vkCreateSurface' will fail.
--
-- Window should have been created with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.
--
-- Throws 'SDL.Exception.SDLException' on failure.
vkGetInstanceExtensions :: MonadIO m => Window -> m [CString]
vkGetInstanceExtensions :: Window -> m [CString]
vkGetInstanceExtensions (Window w :: Window
w) = IO [CString] -> m [CString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CString] -> m [CString])
-> ((Ptr CUInt -> IO [CString]) -> IO [CString])
-> (Ptr CUInt -> IO [CString])
-> m [CString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr CUInt -> IO [CString]) -> IO [CString]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CUInt -> IO [CString]) -> m [CString])
-> (Ptr CUInt -> IO [CString]) -> m [CString]
forall a b. (a -> b) -> a -> b
$ \countPtr :: Ptr CUInt
countPtr -> do
  (Bool -> Bool) -> Text -> Text -> IO Bool -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
(a -> Bool) -> Text -> Text -> m a -> m ()
throwIf_ Bool -> Bool
not "SDL.Video.Vulkan.vkGetInstanceExtensions (1)" "SDL_Vulkan_GetInstanceExtensions" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
    Window -> Ptr CUInt -> Ptr CString -> IO Bool
forall (m :: * -> *).
MonadIO m =>
Window -> Ptr CUInt -> Ptr CString -> m Bool
Raw.vkGetInstanceExtensions Window
w Ptr CUInt
countPtr Ptr CString
forall a. Ptr a
nullPtr
  Int
count <- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> IO CUInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CUInt -> IO CUInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CUInt
countPtr
  Int -> (Ptr CString -> IO [CString]) -> IO [CString]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
count ((Ptr CString -> IO [CString]) -> IO [CString])
-> (Ptr CString -> IO [CString]) -> IO [CString]
forall a b. (a -> b) -> a -> b
$ \sPtr :: Ptr CString
sPtr ->
    (Bool -> Bool) -> Text -> Text -> IO Bool -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
(a -> Bool) -> Text -> Text -> m a -> m ()
throwIf_ Bool -> Bool
not "SDL.Video.Vulkan.vkGetInstanceExtensions (2)" "SDL_Vulkan_GetInstanceExtensions"
      (Window -> Ptr CUInt -> Ptr CString -> IO Bool
forall (m :: * -> *).
MonadIO m =>
Window -> Ptr CUInt -> Ptr CString -> m Bool
Raw.vkGetInstanceExtensions Window
w Ptr CUInt
countPtr Ptr CString
sPtr) IO () -> IO [CString] -> IO [CString]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Ptr CString -> IO [CString]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
count Ptr CString
sPtr

-- | Create a Vulkan rendering surface for a window.
--
-- Window should have been created with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.
--
-- Instance should have been created with the extensions returned
-- by 'vkGetInstanceExtensions' enabled.
--
-- Throws 'SDL.Exception.SDLException' on failure.
vkCreateSurface :: MonadIO m => Window -> VkInstance -> m VkSurfaceKHR
vkCreateSurface :: Window -> Window -> m VkSurfaceKHR
vkCreateSurface (Window w :: Window
w) vkInstance :: Window
vkInstance = IO VkSurfaceKHR -> m VkSurfaceKHR
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VkSurfaceKHR -> m VkSurfaceKHR)
-> ((Ptr VkSurfaceKHR -> IO VkSurfaceKHR) -> IO VkSurfaceKHR)
-> (Ptr VkSurfaceKHR -> IO VkSurfaceKHR)
-> m VkSurfaceKHR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr VkSurfaceKHR -> IO VkSurfaceKHR) -> IO VkSurfaceKHR
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr VkSurfaceKHR -> IO VkSurfaceKHR) -> m VkSurfaceKHR)
-> (Ptr VkSurfaceKHR -> IO VkSurfaceKHR) -> m VkSurfaceKHR
forall a b. (a -> b) -> a -> b
$ \vkSurfacePtr :: Ptr VkSurfaceKHR
vkSurfacePtr ->
  (Bool -> Bool) -> Text -> Text -> IO Bool -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
(a -> Bool) -> Text -> Text -> m a -> m ()
throwIf_ Bool -> Bool
not "SDL.Video.Vulkan.vkCreateSurface" "SDL_Vulkan_CreateSurface"
    (Window -> Window -> Ptr VkSurfaceKHR -> IO Bool
forall (m :: * -> *).
MonadIO m =>
Window -> Window -> Ptr VkSurfaceKHR -> m Bool
Raw.vkCreateSurface Window
w Window
vkInstance Ptr VkSurfaceKHR
vkSurfacePtr) IO () -> IO VkSurfaceKHR -> IO VkSurfaceKHR
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr VkSurfaceKHR -> IO VkSurfaceKHR
forall a. Storable a => Ptr a -> IO a
peek Ptr VkSurfaceKHR
vkSurfacePtr

-- | Get the size of a window's underlying drawable area in pixels (for use
-- with setting viewport, scissor & etc).
--
-- It may differ from 'SDL.Video.windowSize' if window was created with 'SDL.Video.windowHighDPI' flag.
vkGetDrawableSize :: MonadIO m => Window -> m (V2 CInt)
vkGetDrawableSize :: Window -> m (V2 CInt)
vkGetDrawableSize (Window w :: Window
w) = IO (V2 CInt) -> m (V2 CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (V2 CInt) -> m (V2 CInt))
-> ((Ptr CInt -> IO (V2 CInt)) -> IO (V2 CInt))
-> (Ptr CInt -> IO (V2 CInt))
-> m (V2 CInt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr CInt -> IO (V2 CInt)) -> IO (V2 CInt)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (V2 CInt)) -> m (V2 CInt))
-> (Ptr CInt -> IO (V2 CInt)) -> m (V2 CInt)
forall a b. (a -> b) -> a -> b
$ \wptr :: Ptr CInt
wptr ->
  (Ptr CInt -> IO (V2 CInt)) -> IO (V2 CInt)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (V2 CInt)) -> IO (V2 CInt))
-> (Ptr CInt -> IO (V2 CInt)) -> IO (V2 CInt)
forall a b. (a -> b) -> a -> b
$ \hptr :: Ptr CInt
hptr -> do
    Window -> Ptr CInt -> Ptr CInt -> IO ()
forall (m :: * -> *).
MonadIO m =>
Window -> Ptr CInt -> Ptr CInt -> m ()
Raw.vkGetDrawableSize Window
w Ptr CInt
wptr Ptr CInt
hptr
    CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (CInt -> CInt -> V2 CInt) -> IO CInt -> IO (CInt -> V2 CInt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
wptr IO (CInt -> V2 CInt) -> IO CInt -> IO (V2 CInt)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
hptr