{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Graphics.UI.GlfwG.Window (

	-- * CREATE AND DESTROY

	W, create, Group, group, create', unsafeDestroy, lookup,

	shouldClose, setShouldClose,

	-- ** HINT

	hint, B.WindowHint(..),
	B.ClientAPI(..),

	-- * PARAMETER

	getSize, setSize,
	getFrameSize,
	getFramebufferSize,

	-- * CALLBACK

	setKeyCallback, KeyCallback,
	setFramebufferSizeCallback, B.FramebufferSizeCallback,

	-- * STATE

	getKey

	) where

import Prelude hiding (lookup)

import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Data.Map qualified as M

import Graphics.UI.GLFW qualified as B
import Graphics.UI.GlfwG.Window.Type

data Group s k = Group TSem (TVar (M.Map k (W s)))

create :: Int -> Int -> String -> Maybe B.Monitor -> Maybe B.Window ->
	(forall s . W s -> IO a) -> IO a
create :: forall a.
Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> (forall s. W s -> IO a)
-> IO a
create Int
wd Int
hg String
ttl Maybe Monitor
mm Maybe Window
mws forall s. W s -> IO a
f = (forall s. Group s () -> IO a) -> IO a
forall k a. (forall s. Group s k -> IO a) -> IO a
group \Group s ()
g -> W s -> IO a
forall s. W s -> IO a
f (W s -> IO a)
-> (Either String (W s) -> W s) -> Either String (W s) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String (W s) -> W s
forall {a} {a}. Either a a -> a
fromRight (Either String (W s) -> IO a) -> IO (Either String (W s)) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Group s ()
-> ()
-> Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> IO (Either String (W s))
forall k s.
Ord k =>
Group s k
-> k
-> Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> IO (Either String (W s))
create' Group s ()
g () Int
wd Int
hg String
ttl Maybe Monitor
mm Maybe Window
mws
	where fromRight :: Either a a -> a
fromRight = \case Left a
_ -> String -> a
forall a. HasCallStack => String -> a
error String
"never occur"; Right a
w -> a
w

group :: (forall s . Group s k -> IO a) -> IO a
group :: forall k a. (forall s. Group s k -> IO a) -> IO a
group forall s. Group s k -> IO a
f = do
	(TSem
sem, TVar (Map k (W Any))
m) <- STM (TSem, TVar (Map k (W Any))) -> IO (TSem, TVar (Map k (W Any)))
forall a. STM a -> IO a
atomically (STM (TSem, TVar (Map k (W Any)))
 -> IO (TSem, TVar (Map k (W Any))))
-> STM (TSem, TVar (Map k (W Any)))
-> IO (TSem, TVar (Map k (W Any)))
forall a b. (a -> b) -> a -> b
$ (,) (TSem -> TVar (Map k (W Any)) -> (TSem, TVar (Map k (W Any))))
-> STM TSem
-> STM (TVar (Map k (W Any)) -> (TSem, TVar (Map k (W Any))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM TSem
newTSem Integer
1 STM (TVar (Map k (W Any)) -> (TSem, TVar (Map k (W Any))))
-> STM (TVar (Map k (W Any))) -> STM (TSem, TVar (Map k (W Any)))
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map k (W Any) -> STM (TVar (Map k (W Any)))
forall a. a -> STM (TVar a)
newTVar Map k (W Any)
forall k a. Map k a
M.empty
	a
rtn <- Group Any k -> IO a
forall s. Group s k -> IO a
f (Group Any k -> IO a) -> Group Any k -> IO a
forall a b. (a -> b) -> a -> b
$ TSem -> TVar (Map k (W Any)) -> Group Any k
forall s k. TSem -> TVar (Map k (W s)) -> Group s k
Group TSem
sem TVar (Map k (W Any))
m
	((\(W Window
w) -> Window -> IO ()
B.destroyWindow Window
w) (W Any -> IO ()) -> Map k (W Any) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_`) (Map k (W Any) -> IO ()) -> IO (Map k (W Any)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM (Map k (W Any)) -> IO (Map k (W Any))
forall a. STM a -> IO a
atomically (TVar (Map k (W Any)) -> STM (Map k (W Any))
forall a. TVar a -> STM a
readTVar TVar (Map k (W Any))
m)
	a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
rtn

create' :: Ord k => Group s k -> k -> Int -> Int -> String ->
	Maybe B.Monitor -> Maybe B.Window -> IO (Either String (W s))
create' :: forall k s.
Ord k =>
Group s k
-> k
-> Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> IO (Either String (W s))
create' (Group TSem
sem TVar (Map k (W s))
ws) k
k Int
wd Int
hg String
ttl Maybe Monitor
mm Maybe Window
mws = do
	Bool
ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		Maybe (W s)
mx <- k -> Map k (W s) -> Maybe (W s)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k (Map k (W s) -> Maybe (W s))
-> STM (Map k (W s)) -> STM (Maybe (W s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (W s)) -> STM (Map k (W s))
forall a. TVar a -> STM a
readTVar TVar (Map k (W s))
ws
		case Maybe (W s)
mx of
			Maybe (W s)
Nothing -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM Bool -> STM Bool
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
			Just W s
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if Bool
ok
	then do	Maybe (W s)
mw <- (Window -> W s
forall s. Window -> W s
W (Window -> W s) -> Maybe Window -> Maybe (W s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe Window -> Maybe (W s))
-> IO (Maybe Window) -> IO (Maybe (W s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> IO (Maybe Window)
B.createWindow Int
wd Int
hg String
ttl Maybe Monitor
mm Maybe Window
mws
		case Maybe (W s)
mw of
			Just W s
w -> STM (Either String (W s)) -> IO (Either String (W s))
forall a. STM a -> IO a
atomically do
				TVar (Map k (W s)) -> (Map k (W s) -> Map k (W s)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (W s))
ws (k -> W s -> Map k (W s) -> Map k (W s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k W s
w) 
				TSem -> STM ()
signalTSem TSem
sem
				Either String (W s) -> STM (Either String (W s))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (W s) -> STM (Either String (W s)))
-> Either String (W s) -> STM (Either String (W s))
forall a b. (a -> b) -> a -> b
$ W s -> Either String (W s)
forall a b. b -> Either a b
Right W s
w
			Maybe (W s)
Nothing -> Either String (W s) -> IO (Either String (W s))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (W s) -> IO (Either String (W s)))
-> (String -> Either String (W s))
-> String
-> IO (Either String (W s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (W s)
forall a b. a -> Either a b
Left (String -> IO (Either String (W s)))
-> String -> IO (Either String (W s))
forall a b. (a -> b) -> a -> b
$
				String
"Gpu.Vulkan.Khr.Surface." String -> String -> String
forall a. [a] -> [a] -> [a]
++
				String
"Glfw.Window.create': GLFW-b: error"
	else Either String (W s) -> IO (Either String (W s))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (W s) -> IO (Either String (W s)))
-> (String -> Either String (W s))
-> String
-> IO (Either String (W s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (W s)
forall a b. a -> Either a b
Left (String -> IO (Either String (W s)))
-> String -> IO (Either String (W s))
forall a b. (a -> b) -> a -> b
$ String
"Gpu.Vulkan.Khr.Surface.Glfw.Window.create': " String -> String -> String
forall a. [a] -> [a] -> [a]
++
		String
"The key already exist"

unsafeDestroy :: Ord k => Group s k -> k -> IO (Either String ())
unsafeDestroy :: forall k s. Ord k => Group s k -> k -> IO (Either String ())
unsafeDestroy (Group TSem
sem TVar (Map k (W s))
ws) k
k = do
	Maybe (W s)
mw <- STM (Maybe (W s)) -> IO (Maybe (W s))
forall a. STM a -> IO a
atomically do
		Maybe (W s)
mx <- k -> Map k (W s) -> Maybe (W s)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k (Map k (W s) -> Maybe (W s))
-> STM (Map k (W s)) -> STM (Maybe (W s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (W s)) -> STM (Map k (W s))
forall a. TVar a -> STM a
readTVar TVar (Map k (W s))
ws
		case Maybe (W s)
mx of
			Maybe (W s)
Nothing -> Maybe (W s) -> STM (Maybe (W s))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (W s)
forall a. Maybe a
Nothing
			Just W s
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe (W s)) -> STM (Maybe (W s))
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (W s) -> STM (Maybe (W s))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (W s)
mx
	case Maybe (W s)
mw of
		Maybe (W s)
Nothing -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> IO (Either String ()))
-> (String -> Either String ()) -> String -> IO (Either String ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String ()
forall a b. a -> Either a b
Left (String -> IO (Either String ()))
-> String -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$
			String
"Gpu.Vulkan.Khr.Surface.Glfw.Window.destroy: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
			String
"No such key"
		Just (W Window
w) -> do
			Window -> IO ()
B.destroyWindow Window
w
			STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
				TVar (Map k (W s)) -> (Map k (W s) -> Map k (W s)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (W s))
ws (k -> Map k (W s) -> Map k (W s)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
k)
				TSem -> STM ()
signalTSem TSem
sem
				Either String () -> STM (Either String ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> STM (Either String ()))
-> Either String () -> STM (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()

hint :: B.WindowHint -> IO ()
hint :: WindowHint -> IO ()
hint = WindowHint -> IO ()
B.windowHint

lookup :: Ord k => Group s k -> k -> IO (Maybe (W s))
lookup :: forall k s. Ord k => Group s k -> k -> IO (Maybe (W s))
lookup (Group TSem
_sem TVar (Map k (W s))
ws) k
k = STM (Maybe (W s)) -> IO (Maybe (W s))
forall a. STM a -> IO a
atomically (STM (Maybe (W s)) -> IO (Maybe (W s)))
-> STM (Maybe (W s)) -> IO (Maybe (W s))
forall a b. (a -> b) -> a -> b
$ k -> Map k (W s) -> Maybe (W s)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k (Map k (W s) -> Maybe (W s))
-> STM (Map k (W s)) -> STM (Maybe (W s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (W s)) -> STM (Map k (W s))
forall a. TVar a -> STM a
readTVar TVar (Map k (W s))
ws

setFramebufferSizeCallback :: W s -> Maybe B.FramebufferSizeCallback -> IO ()
setFramebufferSizeCallback :: forall s. W s -> Maybe FramebufferSizeCallback -> IO ()
setFramebufferSizeCallback (W Window
w) = Window -> Maybe FramebufferSizeCallback -> IO ()
B.setFramebufferSizeCallback Window
w

getSize :: W sw -> IO (Int, Int)
getSize :: forall sw. W sw -> IO (Int, Int)
getSize (W Window
w) = Window -> IO (Int, Int)
B.getWindowSize Window
w

setSize :: W sw -> Int -> Int -> IO ()
setSize :: forall sw. W sw -> Int -> Int -> IO ()
setSize (W Window
w) = FramebufferSizeCallback
B.setWindowSize Window
w

getFrameSize :: W sw -> IO (Int, Int, Int, Int)
getFrameSize :: forall sw. W sw -> IO (Int, Int, Int, Int)
getFrameSize (W Window
w) = Window -> IO (Int, Int, Int, Int)
B.getWindowFrameSize Window
w

getFramebufferSize :: W sw -> IO (Int, Int)
getFramebufferSize :: forall sw. W sw -> IO (Int, Int)
getFramebufferSize (W Window
w) = Window -> IO (Int, Int)
B.getFramebufferSize Window
w

setKeyCallback :: W s -> Maybe (KeyCallback s) -> IO ()
setKeyCallback :: forall s. W s -> Maybe (KeyCallback s) -> IO ()
setKeyCallback (W Window
w) = Window -> Maybe KeyCallback -> IO ()
B.setKeyCallback Window
w (Maybe KeyCallback -> IO ())
-> (Maybe (KeyCallback s) -> Maybe KeyCallback)
-> Maybe (KeyCallback s)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((KeyCallback s -> (Window -> W s) -> KeyCallback
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> W s
forall s. Window -> W s
W) (KeyCallback s -> KeyCallback)
-> Maybe (KeyCallback s) -> Maybe KeyCallback
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

type KeyCallback s = W s -> B.Key -> Int -> B.KeyState -> B.ModifierKeys -> IO ()

shouldClose :: W sw -> IO Bool
shouldClose :: forall sw. W sw -> IO Bool
shouldClose (W Window
w) = Window -> IO Bool
B.windowShouldClose Window
w

setShouldClose :: W sw -> Bool -> IO ()
setShouldClose :: forall sw. W sw -> Bool -> IO ()
setShouldClose (W Window
w) = Window -> Bool -> IO ()
B.setWindowShouldClose Window
w

getKey :: W sw -> B.Key -> IO B.KeyState
getKey :: forall sw. W sw -> Key -> IO KeyState
getKey (W Window
w) = Window -> Key -> IO KeyState
B.getKey Window
w