{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Graphics.UI.GlfwG (

	init, ErrorMessage, getRequiredInstanceExtensions,

	GlfwB.pollEvents, GlfwB.waitEvents

	) where

import Prelude hiding (init)

import Foreign.Ptr
import Foreign.Storable
import Foreign.C.String
import Control.Exception
import Data.Bool
import Data.Text qualified as Txt
import Data.Text.Foreign qualified as Txt

import qualified Graphics.UI.GLFW as GlfwB

init :: (ErrorMessage -> IO a) -> IO a -> IO a
init :: forall a. (ErrorMessage -> IO a) -> IO a -> IO a
init ErrorMessage -> IO a
hdl IO a
cmp = IO Bool
GlfwB.init IO Bool -> (Bool -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> IO a -> Bool -> IO a
forall a. a -> a -> Bool -> a
bool
	(ErrorMessage -> IO a
hdl (ErrorMessage -> IO a) -> ErrorMessage -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorMessage
"Gpu.Vulkan.Khr.Surface.Glfw: " ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. [a] -> [a] -> [a]
++
		ErrorMessage
"GLFW-b.Graphics.UI.GLFW.init return False")
	(IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
finally IO a
cmp IO ()
GlfwB.terminate)

type ErrorMessage = String

getRequiredInstanceExtensions :: IO [Txt.Text]
getRequiredInstanceExtensions :: IO [Text]
getRequiredInstanceExtensions = (CString -> IO Text
cstrToText (CString -> IO Text) -> [CString] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM`) ([CString] -> IO [Text]) -> IO [CString] -> IO [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [CString]
GlfwB.getRequiredInstanceExtensions

cstrToText :: CString -> IO Txt.Text
cstrToText :: CString -> IO Text
cstrToText CString
cs = CStringLen -> IO Text
Txt.peekCStringLen (CStringLen -> IO Text) -> IO CStringLen -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO CStringLen
cstringToCStringLen CString
cs

cstringLength :: CString -> IO Int
cstringLength :: CString -> IO Int
cstringLength CString
pc = do
	CChar
c <- CString -> IO CChar
forall a. Storable a => Ptr a -> IO a
peek CString
pc
	case CChar
c of
		CChar
0 -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
		CChar
_ -> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO Int
cstringLength (CString
pc CString -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)

cstringToCStringLen :: CString -> IO CStringLen
cstringToCStringLen :: CString -> IO CStringLen
cstringToCStringLen CString
cs = (CString
cs ,) (Int -> CStringLen) -> IO Int -> IO CStringLen
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO Int
cstringLength CString
cs