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

module Gpu.Vulkan.Semaphore.Internal (

	-- * CREATE

	create, S(..), M.CreateInfo(..),

	-- ** Group

	group, Group, create', unsafeDestroy, lookup,

	) where

import Prelude hiding (lookup)
import Foreign.Storable.PeekPoke
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Exception
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.TypeLevel.Tuple.Uncurry
import Data.Map qualified as Map
import Data.Word

import qualified Gpu.Vulkan.Device.Type as Device
import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks
import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks
import qualified Gpu.Vulkan.Semaphore.Middle as M

import Gpu.Vulkan.Semaphore.Type

create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>
	Device.D sd -> M.CreateInfo mn ->
	TPMaybe.M (U2 AllocationCallbacks.A) mac ->
	(forall ss . S ss -> IO a) -> IO a
create :: forall (mn :: Maybe (*)) (mac :: Maybe (*, *)) sd a.
(WithPoked (M mn), ToMiddle mac) =>
D sd
-> CreateInfo mn
-> M (U2 A) mac
-> (forall ss. S ss -> IO a)
-> IO a
create (Device.D D
dvc) CreateInfo mn
ci
	(M (U2 A) mac -> M A (Snd mac)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd mac)
macc) forall ss. S ss -> IO a
f = IO S -> (S -> IO ()) -> (S -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
	(D -> CreateInfo mn -> M A (Snd mac) -> IO S
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO S
M.create D
dvc CreateInfo mn
ci M A (Snd mac)
macc) (\S
s -> D -> S -> M A (Snd mac) -> IO ()
forall (md :: Maybe (*)). D -> S -> M A md -> IO ()
M.destroy D
dvc S
s M A (Snd mac)
macc) (S Any -> IO a
forall ss. S ss -> IO a
f (S Any -> IO a) -> (S -> S Any) -> S -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> S Any
forall s. S -> S s
S)

data Group sd ma ss k = Group (Device.D sd)
	(TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (S ss)))

group :: AllocationCallbacks.ToMiddle ma =>
	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->
	(forall ss . Group sd ma ss k -> IO a) -> IO a
group :: forall (ma :: Maybe (*, *)) sd k a.
ToMiddle ma =>
D sd
-> M (U2 A) ma -> (forall ss. Group sd ma ss k -> IO a) -> IO a
group dvc :: D sd
dvc@(Device.D D
mdvc) mac :: M (U2 A) ma
mac@(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
mmac) forall ss. Group sd ma ss k -> IO a
f = do
	(sem, m) <- STM (TSem, TVar (Map k (S Any))) -> IO (TSem, TVar (Map k (S Any)))
forall a. STM a -> IO a
atomically (STM (TSem, TVar (Map k (S Any)))
 -> IO (TSem, TVar (Map k (S Any))))
-> STM (TSem, TVar (Map k (S Any)))
-> IO (TSem, TVar (Map k (S Any)))
forall a b. (a -> b) -> a -> b
$ (,) (TSem -> TVar (Map k (S Any)) -> (TSem, TVar (Map k (S Any))))
-> STM TSem
-> STM (TVar (Map k (S Any)) -> (TSem, TVar (Map k (S Any))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM TSem
newTSem Integer
1 STM (TVar (Map k (S Any)) -> (TSem, TVar (Map k (S Any))))
-> STM (TVar (Map k (S Any))) -> STM (TSem, TVar (Map k (S 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 (S Any) -> STM (TVar (Map k (S Any)))
forall a. a -> STM (TVar a)
newTVar Map k (S Any)
forall k a. Map k a
Map.empty
	rtn <- f $ Group dvc mac sem m
	((\(S S
s) -> D -> S -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> S -> M A md -> IO ()
M.destroy D
mdvc S
s M A (Snd ma)
mmac) `mapM_`) =<< atomically (readTVar m)
	pure rtn

create' :: (
	Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) =>
	Group sd ma ss k -> k -> M.CreateInfo mn -> IO (Either String (S ss))
create' :: forall k (mn :: Maybe (*)) (ma :: Maybe (*, *)) sd ss.
(Ord k, WithPoked (M mn), ToMiddle ma) =>
Group sd ma ss k -> k -> CreateInfo mn -> IO (Either String (S ss))
create' (Group (Device.D D
mdvc)
	(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
mmac) TSem
sem TVar (Map k (S ss))
ss) k
k CreateInfo mn
ci = do
	ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		mx <- k -> Map k (S ss) -> Maybe (S ss)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (S ss) -> Maybe (S ss))
-> STM (Map k (S ss)) -> STM (Maybe (S ss))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (S ss)) -> STM (Map k (S ss))
forall a. TVar a -> STM a
readTVar TVar (Map k (S ss))
ss
		case mx of
			Maybe (S ss)
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 S ss
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if ok
	then do	s <- M.create mdvc ci mmac
		let	s' = S -> S ss
forall s. S -> S s
S S
s
		atomically $ modifyTVar ss (Map.insert k s') >> signalTSem sem
		pure $ Right s'
	else pure . Left $
		"Gpu.Vulkan.Semaphore.Internal.create': The key already exist"

unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>
	Group sd ma ss k -> k -> IO (Either String ())
unsafeDestroy :: forall k (ma :: Maybe (*, *)) sd ss.
(Ord k, ToMiddle ma) =>
Group sd ma ss k -> k -> IO (Either String ())
unsafeDestroy (Group (Device.D D
mdvc)
	(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
ma) TSem
sem TVar (Map k (S ss))
ss) k
k = do
	ms <- STM (Maybe (S ss)) -> IO (Maybe (S ss))
forall a. STM a -> IO a
atomically do
		mx <- k -> Map k (S ss) -> Maybe (S ss)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (S ss) -> Maybe (S ss))
-> STM (Map k (S ss)) -> STM (Maybe (S ss))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (S ss)) -> STM (Map k (S ss))
forall a. TVar a -> STM a
readTVar TVar (Map k (S ss))
ss
		case mx of
			Maybe (S ss)
Nothing -> Maybe (S ss) -> STM (Maybe (S ss))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (S ss)
forall a. Maybe a
Nothing
			Just S ss
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe (S ss)) -> STM (Maybe (S ss))
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (S ss) -> STM (Maybe (S ss))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (S ss)
mx
	case ms of
		Maybe (S ss)
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 ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left
			String
"Gpu.Vulkan.Semaphore.unsafeDestroy: No such key"
		Just (S S
s) -> do
			D -> S -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> S -> M A md -> IO ()
M.destroy D
mdvc S
s M A (Snd ma)
ma
			STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
				TVar (Map k (S ss)) -> (Map k (S ss) -> Map k (S ss)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (S ss))
ss ((Map k (S ss) -> Map k (S ss)) -> STM ())
-> (Map k (S ss) -> Map k (S ss)) -> STM ()
forall a b. (a -> b) -> a -> b
$ k -> Map k (S ss) -> Map k (S ss)
forall k a. Ord k => k -> Map k a -> Map k a
Map.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 ()

lookup :: Ord k => Group sd ma ss k -> k -> IO (Maybe (S ss))
lookup :: forall k sd (ma :: Maybe (*, *)) ss.
Ord k =>
Group sd ma ss k -> k -> IO (Maybe (S ss))
lookup (Group D sd
_ M (U2 A) ma
_ TSem
_sem TVar (Map k (S ss))
ss) k
k = STM (Maybe (S ss)) -> IO (Maybe (S ss))
forall a. STM a -> IO a
atomically (STM (Maybe (S ss)) -> IO (Maybe (S ss)))
-> STM (Maybe (S ss)) -> IO (Maybe (S ss))
forall a b. (a -> b) -> a -> b
$ k -> Map k (S ss) -> Maybe (S ss)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (S ss) -> Maybe (S ss))
-> STM (Map k (S ss)) -> STM (Maybe (S ss))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (S ss)) -> STM (Map k (S ss))
forall a. TVar a -> STM a
readTVar TVar (Map k (S ss))
ss