{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Khr.Surface.Internal (
	S(..), group, unsafeDestroy, lookup, Group(..),

	M.Capabilities(..),
	Format(..), formatListToNew, formatFilter ) where

import Prelude hiding (lookup)
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.TypeLevel.Tuple.Uncurry
import Data.Proxy
import Data.Maybe
import Data.HeteroParList.Constrained (pattern (:^*))
import Data.HeteroParList.Constrained qualified as HeteroParListC
import Data.Map qualified as Map

import Gpu.Vulkan.TypeEnum qualified as T
import Gpu.Vulkan.Instance.Internal qualified as Instance
import Gpu.Vulkan.AllocationCallbacks.Internal qualified as AllocationCallbacks
import Gpu.Vulkan.Khr.Surface.Enum
import Gpu.Vulkan.Khr.Surface.Type
import Gpu.Vulkan.Khr.Surface.Middle qualified as M

data Group si ma s k = Group (Instance.I si)
	(TPMaybe.M (U2 AllocationCallbacks.A) ma)
	TSem (TVar (Map.Map k (S s)))

group :: AllocationCallbacks.ToMiddle ma =>
	Instance.I si -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->
	(forall s . Group si ma s k -> IO a) -> IO a
group :: forall (ma :: Maybe (*, *)) si k a.
ToMiddle ma =>
I si -> M (U2 A) ma -> (forall s. Group si ma s k -> IO a) -> IO a
group i :: I si
i@(Instance.I I
mi) 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)
ma) forall s. Group si ma s 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 i mac sem m
	((\(S S
s) -> I -> S -> M A (Snd ma) -> IO ()
forall (mn :: Maybe (*)). I -> S -> M A mn -> IO ()
M.destroy I
mi S
s M A (Snd ma)
ma) `mapM_`) =<< atomically (readTVar m)
	pure rtn

unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>
	Group si ma s k -> k -> IO (Either String ())
unsafeDestroy :: forall k (ma :: Maybe (*, *)) si s.
(Ord k, ToMiddle ma) =>
Group si ma s k -> k -> IO (Either String ())
unsafeDestroy (Group (Instance.I I
mi) (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 s))
ss) k
k =
	do	mbs <- STM (Maybe (S s)) -> IO (Maybe (S s))
forall a. STM a -> IO a
atomically do
			mx <- k -> Map k (S s) -> Maybe (S s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (S s) -> Maybe (S s))
-> STM (Map k (S s)) -> STM (Maybe (S s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (S s)) -> STM (Map k (S s))
forall a. TVar a -> STM a
readTVar TVar (Map k (S s))
ss
			case mx of
				Maybe (S s)
Nothing -> Maybe (S s) -> STM (Maybe (S s))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (S s)
forall a. Maybe a
Nothing
				Just S s
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe (S s)) -> STM (Maybe (S s))
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (S s) -> STM (Maybe (S s))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (S s)
mx
		case mbs of
			Maybe (S 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 ()))
-> 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.Khr.Surface.Internal.unsafeDestroy: No such key"
			Just (S S
ms) -> do
				I -> S -> M A (Snd ma) -> IO ()
forall (mn :: Maybe (*)). I -> S -> M A mn -> IO ()
M.destroy I
mi S
ms M A (Snd ma)
ma
				STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
					TVar (Map k (S s)) -> (Map k (S s) -> Map k (S s)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (S s))
ss (k -> Map k (S s) -> Map k (S s)
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 si ma s k -> k -> IO (Maybe (S s))
lookup :: forall k si (ma :: Maybe (*, *)) s.
Ord k =>
Group si ma s k -> k -> IO (Maybe (S s))
lookup (Group I si
_ M (U2 A) ma
_ TSem
_sem TVar (Map k (S s))
ss) k
k = STM (Maybe (S s)) -> IO (Maybe (S s))
forall a. STM a -> IO a
atomically (STM (Maybe (S s)) -> IO (Maybe (S s)))
-> STM (Maybe (S s)) -> IO (Maybe (S s))
forall a b. (a -> b) -> a -> b
$ k -> Map k (S s) -> Maybe (S s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (S s) -> Maybe (S s))
-> STM (Map k (S s)) -> STM (Maybe (S s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (S s)) -> STM (Map k (S s))
forall a. TVar a -> STM a
readTVar TVar (Map k (S s))
ss

data Format (fmt :: T.Format) =
	Format { forall (fmt :: Format). Format fmt -> ColorSpace
formatColorSpace :: ColorSpace }

instance T.FormatToValue fmt => Show (Format fmt) where
	show :: Format fmt -> String
show (Format ColorSpace
cs) =
		String
"(Format {- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Format -> String
forall a. Show a => a -> String
show (forall (t :: Format). FormatToValue t => Format
T.formatToValue @fmt) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -} " String -> ShowS
forall a. [a] -> [a] -> [a]
++
		ColorSpace -> String
forall a. Show a => a -> String
show ColorSpace
cs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

formatToNew :: M.Format ->
	(forall fmt . T.FormatToValue fmt => Format fmt -> a) -> a
formatToNew :: forall a.
Format
-> (forall (fmt :: Format). FormatToValue fmt => Format fmt -> a)
-> a
formatToNew (M.Format Format
fmt ColorSpace
cs) forall (fmt :: Format). FormatToValue fmt => Format fmt -> a
f = Format
-> (forall (t :: Format). FormatToValue t => Proxy t -> a) -> a
forall a.
Format
-> (forall (t :: Format). FormatToValue t => Proxy t -> a) -> a
T.formatToType Format
fmt \(Proxy t
_ :: Proxy fmt) -> Format t -> a
forall (fmt :: Format). FormatToValue fmt => Format fmt -> a
f (Format t -> a) -> Format t -> a
forall a b. (a -> b) -> a -> b
$ forall (fmt :: Format). ColorSpace -> Format fmt
Format @fmt ColorSpace
cs

formatListToNew :: [M.Format] -> (forall fmts .
	Show (HeteroParListC.PL T.FormatToValue Format fmts) =>
	HeteroParListC.PL T.FormatToValue Format fmts -> a) -> a
formatListToNew :: forall a.
[Format]
-> (forall (fmts :: [Format]).
    Show (PL FormatToValue Format fmts) =>
    PL FormatToValue Format fmts -> a)
-> a
formatListToNew [] forall (fmts :: [Format]).
Show (PL FormatToValue Format fmts) =>
PL FormatToValue Format fmts -> a
f = PL FormatToValue Format '[] -> a
forall (fmts :: [Format]).
Show (PL FormatToValue Format fmts) =>
PL FormatToValue Format fmts -> a
f PL FormatToValue Format '[]
forall {k} (c :: k -> Constraint) (t :: k -> *). PL c t '[]
HeteroParListC.Nil
formatListToNew (Format
fmt : [Format]
fmts) forall (fmts :: [Format]).
Show (PL FormatToValue Format fmts) =>
PL FormatToValue Format fmts -> a
f = Format
-> (forall (fmt :: Format). FormatToValue fmt => Format fmt -> a)
-> a
forall a.
Format
-> (forall (fmt :: Format). FormatToValue fmt => Format fmt -> a)
-> a
formatToNew Format
fmt \Format fmt
fmt' ->
	[Format]
-> (forall (fmts :: [Format]).
    Show (PL FormatToValue Format fmts) =>
    PL FormatToValue Format fmts -> a)
-> a
forall a.
[Format]
-> (forall (fmts :: [Format]).
    Show (PL FormatToValue Format fmts) =>
    PL FormatToValue Format fmts -> a)
-> a
formatListToNew [Format]
fmts \PL FormatToValue Format fmts
fmts' -> PL FormatToValue Format (fmt : fmts) -> a
forall (fmts :: [Format]).
Show (PL FormatToValue Format fmts) =>
PL FormatToValue Format fmts -> a
f (PL FormatToValue Format (fmt : fmts) -> a)
-> PL FormatToValue Format (fmt : fmts) -> a
forall a b. (a -> b) -> a -> b
$ Format fmt
fmt' Format fmt
-> PL FormatToValue Format fmts
-> PL FormatToValue Format (fmt : fmts)
forall {k} (c :: k -> Constraint) (s :: k) (t :: k -> *)
       (ss1 :: [k]).
c s =>
t s -> PL c t ss1 -> PL c t (s : ss1)
:^* PL FormatToValue Format fmts
fmts'

formatMatched :: forall fmt . T.FormatToValue fmt =>
	M.Format -> Maybe (Format fmt)
formatMatched :: forall (fmt :: Format).
FormatToValue fmt =>
Format -> Maybe (Format fmt)
formatMatched (M.Format Format
fmt ColorSpace
cs)
	| forall (t :: Format). FormatToValue t => Format
T.formatToValue @fmt Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
fmt = Format fmt -> Maybe (Format fmt)
forall a. a -> Maybe a
Just (Format fmt -> Maybe (Format fmt))
-> Format fmt -> Maybe (Format fmt)
forall a b. (a -> b) -> a -> b
$ ColorSpace -> Format fmt
forall (fmt :: Format). ColorSpace -> Format fmt
Format ColorSpace
cs
	| Bool
otherwise = Maybe (Format fmt)
forall a. Maybe a
Nothing

formatFilter :: forall fmt . T.FormatToValue fmt =>
	[M.Format] -> [Format fmt]
formatFilter :: forall (fmt :: Format).
FormatToValue fmt =>
[Format] -> [Format fmt]
formatFilter = [Maybe (Format fmt)] -> [Format fmt]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Format fmt)] -> [Format fmt])
-> ([Format] -> [Maybe (Format fmt)]) -> [Format] -> [Format fmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Format -> Maybe (Format fmt)
forall (fmt :: Format).
FormatToValue fmt =>
Format -> Maybe (Format fmt)
formatMatched (Format -> Maybe (Format fmt)) -> [Format] -> [Maybe (Format fmt)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

{-
type FormatConstraint fmt = (
	T.FormatToValue fmt,
	MaybeFormat fmt )

-- class FilterFormat (fmts :: [T.Format]) where
--	filterFormat :: HeteroParListC.

class MaybeFormat (fmt0 :: T.Format) (fmt :: T.Format) where
	maybeFormat :: FormatNew fmt -> Maybe (FormatNew fmt0)

instance MaybeFormat fmt fmt where maybeFormat = Just

instance {-# OVERLAPPABLE #-} MaybeFormat fmt0 fmt where maybeFormat _ = Nothing
-}