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

module Gpu.Vulkan.AllocationCallbacks.Middle.Internal (

	-- * CREATE AND DESTROY

	create, destroy, Functions, FunctionsInfo(..),

	-- ** Function Types

	FnAllocationFunction, FnReallocationFunction, C.FnFreeFunction,
	FnInternalAllocationNotification, FnInternalFreeNotification,

	-- *** size and alignment

	Size, Alignment,

	-- * APPLY

	apply, A,

	-- * INTERNAL USE

	mToCore

	) where

import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import Foreign.Storable.PeekPoke
import Control.Monad
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.Word

import Gpu.Vulkan.Enum
import Gpu.Vulkan.AllocationCallbacks.Core qualified as C

newtype A a = A C.A deriving Int -> A a -> ShowS
[A a] -> ShowS
A a -> String
(Int -> A a -> ShowS)
-> (A a -> String) -> ([A a] -> ShowS) -> Show (A a)
forall a. Int -> A a -> ShowS
forall a. [A a] -> ShowS
forall a. A a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> A a -> ShowS
showsPrec :: Int -> A a -> ShowS
$cshow :: forall a. A a -> String
show :: A a -> String
$cshowList :: forall a. [A a] -> ShowS
showList :: [A a] -> ShowS
Show

data Functions a = Functions {
	forall a. Functions a -> PfnAllocationFunction
aPfnAllocation :: C.PfnAllocationFunction,
	forall a. Functions a -> PfnReallocationFunction
aPfnReallocation :: C.PfnReallocationFunction,
	forall a. Functions a -> PfnFreeFunction
aPfnFree :: C.PfnFreeFunction,
	forall a. Functions a -> PfnInternalAllocationNotification
aPfnInternalAllocation :: C.PfnInternalAllocationNotification,
	forall a. Functions a -> PfnInternalAllocationNotification
aPfnInternalFree :: C.PfnInternalFreeNotification }
	deriving Int -> Functions a -> ShowS
[Functions a] -> ShowS
Functions a -> String
(Int -> Functions a -> ShowS)
-> (Functions a -> String)
-> ([Functions a] -> ShowS)
-> Show (Functions a)
forall a. Int -> Functions a -> ShowS
forall a. [Functions a] -> ShowS
forall a. Functions a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Functions a -> ShowS
showsPrec :: Int -> Functions a -> ShowS
$cshow :: forall a. Functions a -> String
show :: Functions a -> String
$cshowList :: forall a. [Functions a] -> ShowS
showList :: [Functions a] -> ShowS
Show

apply :: Functions a -> Ptr a -> A a
apply :: forall a. Functions a -> Ptr a -> A a
apply Functions a
a Ptr a
p = A -> A a
forall a. A -> A a
A C.A {
	aPUserData :: PtrVoid
C.aPUserData = Ptr a -> PtrVoid
forall a b. Ptr a -> Ptr b
castPtr Ptr a
p,
	aPfnAllocation :: PfnAllocationFunction
C.aPfnAllocation = Functions a -> PfnAllocationFunction
forall a. Functions a -> PfnAllocationFunction
aPfnAllocation Functions a
a,
	aPfnReallocation :: PfnReallocationFunction
C.aPfnReallocation = Functions a -> PfnReallocationFunction
forall a. Functions a -> PfnReallocationFunction
aPfnReallocation Functions a
a,
	aPfnFree :: PfnFreeFunction
C.aPfnFree = Functions a -> PfnFreeFunction
forall a. Functions a -> PfnFreeFunction
aPfnFree Functions a
a,
	aPfnInternalAllocation :: PfnInternalAllocationNotification
C.aPfnInternalAllocation = Functions a -> PfnInternalAllocationNotification
forall a. Functions a -> PfnInternalAllocationNotification
aPfnInternalAllocation Functions a
a,
	aPfnInternalFree :: PfnInternalAllocationNotification
C.aPfnInternalFree = Functions a -> PfnInternalAllocationNotification
forall a. Functions a -> PfnInternalAllocationNotification
aPfnInternalFree Functions a
a }

create :: FunctionsInfo a -> IO (Functions a)
create :: forall a. FunctionsInfo a -> IO (Functions a)
create = FunctionsInfo a -> IO (Functions a)
forall a. FunctionsInfo a -> IO (Functions a)
mkCallbacksNew

destroy :: Functions a -> IO ()
destroy :: forall a. Functions a -> IO ()
destroy Functions a
a = do
	PfnAllocationFunction -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr PfnAllocationFunction
allc
	PfnReallocationFunction -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr PfnReallocationFunction
rallc
	PfnFreeFunction -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr PfnFreeFunction
fr
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PfnInternalAllocationNotification
iallc PfnInternalAllocationNotification
-> PfnInternalAllocationNotification -> Bool
forall a. Eq a => a -> a -> Bool
/= PfnInternalAllocationNotification
forall a. FunPtr a
nullFunPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PfnInternalAllocationNotification -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr PfnInternalAllocationNotification
iallc
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PfnInternalAllocationNotification
ifr PfnInternalAllocationNotification
-> PfnInternalAllocationNotification -> Bool
forall a. Eq a => a -> a -> Bool
/= PfnInternalAllocationNotification
forall a. FunPtr a
nullFunPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PfnInternalAllocationNotification -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr PfnInternalAllocationNotification
ifr
	where
	allc :: PfnAllocationFunction
allc = Functions a -> PfnAllocationFunction
forall a. Functions a -> PfnAllocationFunction
aPfnAllocation Functions a
a
	rallc :: PfnReallocationFunction
rallc = Functions a -> PfnReallocationFunction
forall a. Functions a -> PfnReallocationFunction
aPfnReallocation Functions a
a
	fr :: PfnFreeFunction
fr = Functions a -> PfnFreeFunction
forall a. Functions a -> PfnFreeFunction
aPfnFree Functions a
a
	iallc :: PfnInternalAllocationNotification
iallc = Functions a -> PfnInternalAllocationNotification
forall a. Functions a -> PfnInternalAllocationNotification
aPfnInternalAllocation Functions a
a
	ifr :: PfnInternalAllocationNotification
ifr = Functions a -> PfnInternalAllocationNotification
forall a. Functions a -> PfnInternalAllocationNotification
aPfnInternalFree Functions a
a

data FunctionsInfo a = FunctionsInfo {
	forall a. FunctionsInfo a -> FnAllocationFunction a
functionsInfoFnAllocation :: FnAllocationFunction a,
	forall a. FunctionsInfo a -> FnReallocationFunction a
functionsInfoFnReallocation :: FnReallocationFunction a,
	forall a. FunctionsInfo a -> FnFreeFunction a
functionsInfoFnFree :: C.FnFreeFunction a,
	forall a.
FunctionsInfo a
-> Maybe
     (FnInternalAllocationNotification a,
      FnInternalAllocationNotification a)
functionsInfoFnInternalAllocationFree :: Maybe (
		FnInternalAllocationNotification a,
		FnInternalFreeNotification a ) }

type Size = Word64
type Alignment = Word64

type FnAllocationFunction a =
	Ptr a -> Size -> Alignment -> SystemAllocationScope -> IO (Ptr ())

fnAllocationFunctionToCore :: FnAllocationFunction a -> C.FnAllocationFunction a
fnAllocationFunctionToCore :: forall a. FnAllocationFunction a -> FnAllocationFunction a
fnAllocationFunctionToCore FnAllocationFunction a
f Ptr a
pud Word64
sz Word64
algn Word32
ascp =
	FnAllocationFunction a
f Ptr a
pud Word64
sz Word64
algn (Word32 -> SystemAllocationScope
SystemAllocationScope Word32
ascp)

type FnReallocationFunction a = Ptr a ->
	Ptr () -> Size -> Alignment -> SystemAllocationScope -> IO (Ptr ())

fnReallocationFunctionToCore ::
	FnReallocationFunction a -> C.FnReallocationFunction a
fnReallocationFunctionToCore :: forall a. FnReallocationFunction a -> FnReallocationFunction a
fnReallocationFunctionToCore FnReallocationFunction a
f Ptr a
pud PtrVoid
po Word64
sz Word64
algn Word32
ascp =
	FnReallocationFunction a
f Ptr a
pud PtrVoid
po Word64
sz Word64
algn (Word32 -> SystemAllocationScope
SystemAllocationScope Word32
ascp)

type FnInternalAllocationNotification a = Ptr a ->
	Size -> InternalAllocationType -> SystemAllocationScope -> IO ()

fnInternalAllocationNotificationToCore ::
	FnInternalAllocationNotification a ->
	C.FnInternalAllocationNotification a
fnInternalAllocationNotificationToCore :: forall a.
FnInternalAllocationNotification a
-> FnInternalAllocationNotification a
fnInternalAllocationNotificationToCore FnInternalAllocationNotification a
f Ptr a
pud Word64
sz Word32
iatp Word32
ascp =
	FnInternalAllocationNotification a
f Ptr a
pud Word64
sz (Word32 -> InternalAllocationType
InternalAllocationType Word32
iatp) (Word32 -> SystemAllocationScope
SystemAllocationScope Word32
ascp)

type FnInternalFreeNotification a = Ptr a ->
	Size -> InternalAllocationType -> SystemAllocationScope -> IO ()

fnInternalFreeNotificationToCore ::
	FnInternalFreeNotification a -> C.FnInternalFreeNotification a
fnInternalFreeNotificationToCore :: forall a.
FnInternalAllocationNotification a
-> FnInternalAllocationNotification a
fnInternalFreeNotificationToCore FnInternalFreeNotification a
f Ptr a
pud Word64
sz Word32
iatp Word32
ascp =
	FnInternalFreeNotification a
f Ptr a
pud Word64
sz (Word32 -> InternalAllocationType
InternalAllocationType Word32
iatp) (Word32 -> SystemAllocationScope
SystemAllocationScope Word32
ascp)

mToCore :: TPMaybe.M A ma -> (Ptr C.A -> IO b) -> IO ()
mToCore :: forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
mToCore = ((Ptr A -> IO b) -> IO ())
-> (forall s. A s -> (Ptr A -> IO b) -> IO ())
-> M A ma
-> (Ptr A -> IO b)
-> IO ()
forall {k} a (t :: k -> *) (ms :: Maybe k).
a -> (forall (s :: k). t s -> a) -> M t ms -> a
TPMaybe.maybe ((() () -> IO b -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (IO b -> IO ())
-> ((Ptr A -> IO b) -> IO b) -> (Ptr A -> IO b) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Ptr A -> IO b) -> Ptr A -> IO b
forall a b. (a -> b) -> a -> b
$ Ptr A
forall a. Ptr a
NullPtr)) A s -> (Ptr A -> IO b) -> IO ()
forall s. A s -> (Ptr A -> IO b) -> IO ()
forall a b. A a -> (Ptr A -> IO b) -> IO ()
toCoreNew

toCoreNew :: A a -> (Ptr C.A -> IO b) -> IO ()
toCoreNew :: forall a b. A a -> (Ptr A -> IO b) -> IO ()
toCoreNew (A A
ac) Ptr A -> IO b
f = () () -> IO b -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Ptr A -> IO b) -> IO b
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr A
p -> Ptr A -> A -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr A
p A
ac IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr A -> IO b
f Ptr A
p

mkCallbacksNew :: FunctionsInfo a -> IO (Functions a)
mkCallbacksNew :: forall a. FunctionsInfo a -> IO (Functions a)
mkCallbacksNew FunctionsInfo a
ac = do
	pal <- FnAllocationFunction a -> IO PfnAllocationFunction
forall a. FnAllocationFunction a -> IO PfnAllocationFunction
C.wrapAllocationFunction (FnAllocationFunction a -> IO PfnAllocationFunction)
-> FnAllocationFunction a -> IO PfnAllocationFunction
forall a b. (a -> b) -> a -> b
$ FnAllocationFunction a -> FnAllocationFunction a
forall a. FnAllocationFunction a -> FnAllocationFunction a
fnAllocationFunctionToCore FnAllocationFunction a
al
	pral <- C.wrapReallocationFunction $ fnReallocationFunctionToCore ral
	pfr <- C.wrapFreeFunction fr
	(pial, pifr) <- do
		case functionsInfoFnInternalAllocationFree ac of
			Maybe
  (FnInternalAllocationNotification a,
   FnInternalAllocationNotification a)
Nothing -> (PfnInternalAllocationNotification,
 PfnInternalAllocationNotification)
-> IO
     (PfnInternalAllocationNotification,
      PfnInternalAllocationNotification)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PfnInternalAllocationNotification
forall a. FunPtr a
nullFunPtr, PfnInternalAllocationNotification
forall a. FunPtr a
nullFunPtr)
			Just (FnInternalAllocationNotification a
ial, FnInternalAllocationNotification a
ifr) -> do
				wal <- FnInternalAllocationNotification a
-> IO PfnInternalAllocationNotification
forall a.
FnInternalAllocationNotification a
-> IO PfnInternalAllocationNotification
C.wrapInternalAllocationNotification
					(FnInternalAllocationNotification a
 -> IO PfnInternalAllocationNotification)
-> FnInternalAllocationNotification a
-> IO PfnInternalAllocationNotification
forall a b. (a -> b) -> a -> b
$ FnInternalAllocationNotification a
-> FnInternalAllocationNotification a
forall a.
FnInternalAllocationNotification a
-> FnInternalAllocationNotification a
fnInternalAllocationNotificationToCore FnInternalAllocationNotification a
ial
				wfr <- C.wrapInternalFreeNotification
					$ fnInternalFreeNotificationToCore ifr
				pure (wal, wfr)
	pure Functions {
		aPfnAllocation = pal,
		aPfnReallocation = pral,
		aPfnFree = pfr,
		aPfnInternalAllocation = pial,
		aPfnInternalFree = pifr }
	where
	al :: FnAllocationFunction a
al = FunctionsInfo a -> FnAllocationFunction a
forall a. FunctionsInfo a -> FnAllocationFunction a
functionsInfoFnAllocation FunctionsInfo a
ac
	ral :: FnReallocationFunction a
ral = FunctionsInfo a -> FnReallocationFunction a
forall a. FunctionsInfo a -> FnReallocationFunction a
functionsInfoFnReallocation FunctionsInfo a
ac
	fr :: FnFreeFunction a
fr = FunctionsInfo a -> FnFreeFunction a
forall a. FunctionsInfo a -> FnFreeFunction a
functionsInfoFnFree FunctionsInfo a
ac