{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}
{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures, TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Memory.ImageBuffer (

	-- * IMAGE BUFFER

	ImageBuffer(..), ImageBufferBinded(..), ImageBufferArg(..),

	-- * GET REQUIREMENTS LIST

	getRequirementsList, getRequirementsListBinded,

	-- * ADJUST OFFSET AND GET SIZE

	adjustOffsetSize, adjustOffsetSizeBinded,

	-- * FOR BIND

	Alignments(..),

	-- * FOR READ AND WRITE

	ObjectLength(..),

	-- * OTHERS

	AlgnSize, adjust,

	-- * RAW OFFSET

	RawOffset(..), RawOffsetToOffset(..)

	) where

import Prelude hiding (map, read)
import GHC.TypeLits
import Data.Kind
import Data.TypeLevel.Tuple.Uncurry
import Gpu.Vulkan.Object qualified as VObj
import Data.HeteroParList qualified as HeteroParList
import Data.HeteroParList (pattern (:**))

import qualified Gpu.Vulkan.Image.Type as Image
import qualified Gpu.Vulkan.Buffer.Type as Buffer

import qualified Gpu.Vulkan.TypeEnum as T

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

import qualified Gpu.Vulkan.Image.Middle as Image.M
import qualified Gpu.Vulkan.Buffer.Middle as Buffer.M
import qualified Gpu.Vulkan.Memory.Middle as Memory.M

import qualified Data.HeteroParList as HPList

-- IMAGE BUFFER

data ImageBuffer s (ibarg :: ImageBufferArg) where
	Image :: Image.I si nm fmt -> ImageBuffer si ('ImageArg nm fmt)
	Buffer :: Buffer.B sb nm objs -> ImageBuffer sb ('BufferArg nm objs)
	Raw :: Device.M.Size -> Device.M.Size -> ImageBuffer s RawArg

deriving instance Show (HeteroParList.PL VObj.Length objs) =>
	Show (ImageBuffer sib ('BufferArg nm objs))

data ImageBufferBinded sm sib (ibarg :: ImageBufferArg) where
	ImageBinded :: Image.Binded sm si nm fmt ->
		ImageBufferBinded sm si ('ImageArg nm fmt)
	BufferBinded :: Buffer.Binded sm sb nm objs ->
		ImageBufferBinded sm sb ('BufferArg nm objs)
	RawBinded :: Device.M.Size -> Device.M.Size ->
		ImageBufferBinded sm sb RawArg

deriving instance Show (HeteroParList.PL VObj.Length objs) =>
	Show (ImageBufferBinded sm sib ('BufferArg nm objs))

data ImageBufferArg =
	ImageArg Symbol T.Format | BufferArg Symbol [VObj.O] | RawArg

-- GET REQUIREMENTS LIST

type AlgnSize = (Device.M.Size, Device.M.Size)

getRequirementsList ::
	Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs ->
	IO [Either AlgnSize Memory.M.Requirements]
getRequirementsList :: forall sd (ibargs :: [(*, ImageBufferArg)]).
D sd
-> PL (U2 ImageBuffer) ibargs -> IO [Either AlgnSize Requirements]
getRequirementsList D sd
dv =
	(forall (s :: (*, ImageBufferArg)).
 U2 ImageBuffer s -> IO (Either AlgnSize Requirements))
-> PL (U2 ImageBuffer) ibargs -> IO [Either AlgnSize Requirements]
forall (m :: * -> *) k (t :: k -> *) a (ss :: [k]).
Applicative m =>
(forall (s :: k). t s -> m a) -> PL t ss -> m [a]
HeteroParList.toListM \(U2 ImageBuffer s1 s2
bi) -> D sd -> ImageBuffer s1 s2 -> IO (Either AlgnSize Requirements)
forall sd sib (fos :: ImageBufferArg).
D sd -> ImageBuffer sib fos -> IO (Either AlgnSize Requirements)
getMemoryRequirements D sd
dv ImageBuffer s1 s2
bi

getRequirementsListBinded ::
	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->
	IO [Either AlgnSize Memory.M.Requirements]
getRequirementsListBinded :: forall sd sm (ibargs :: [(*, ImageBufferArg)]).
D sd
-> PL (U2 (ImageBufferBinded sm)) ibargs
-> IO [Either AlgnSize Requirements]
getRequirementsListBinded D sd
dv =
	(forall (s :: (*, ImageBufferArg)).
 U2 (ImageBufferBinded sm) s -> IO (Either AlgnSize Requirements))
-> PL (U2 (ImageBufferBinded sm)) ibargs
-> IO [Either AlgnSize Requirements]
forall (m :: * -> *) k (t :: k -> *) a (ss :: [k]).
Applicative m =>
(forall (s :: k). t s -> m a) -> PL t ss -> m [a]
HeteroParList.toListM \(U2 ImageBufferBinded sm s1 s2
bi) -> D sd
-> ImageBufferBinded sm s1 s2 -> IO (Either AlgnSize Requirements)
forall sd sm sib (fos :: ImageBufferArg).
D sd
-> ImageBufferBinded sm sib fos
-> IO (Either AlgnSize Requirements)
getMemoryRequirementsBinded D sd
dv ImageBufferBinded sm s1 s2
bi

getMemoryRequirements ::
	Device.D sd -> ImageBuffer sib fos -> IO (Either AlgnSize Memory.M.Requirements)
getMemoryRequirements :: forall sd sib (fos :: ImageBufferArg).
D sd -> ImageBuffer sib fos -> IO (Either AlgnSize Requirements)
getMemoryRequirements (Device.D D
dv) = \case
	Buffer (Buffer.B PL Length objs
_ B
b) -> Requirements -> Either AlgnSize Requirements
forall a b. b -> Either a b
Right (Requirements -> Either AlgnSize Requirements)
-> IO Requirements -> IO (Either AlgnSize Requirements)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D -> B -> IO Requirements
Buffer.M.getMemoryRequirements D
dv B
b
	Image (Image.I I
i) -> Requirements -> Either AlgnSize Requirements
forall a b. b -> Either a b
Right (Requirements -> Either AlgnSize Requirements)
-> IO Requirements -> IO (Either AlgnSize Requirements)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D -> I -> IO Requirements
Image.M.getMemoryRequirements D
dv I
i
	Raw Size
algn Size
sz -> Either AlgnSize Requirements -> IO (Either AlgnSize Requirements)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AlgnSize Requirements -> IO (Either AlgnSize Requirements))
-> Either AlgnSize Requirements
-> IO (Either AlgnSize Requirements)
forall a b. (a -> b) -> a -> b
$ AlgnSize -> Either AlgnSize Requirements
forall a b. a -> Either a b
Left (Size
algn, Size
sz)

getMemoryRequirementsBinded ::
	Device.D sd -> ImageBufferBinded sm sib fos -> IO (Either AlgnSize Memory.M.Requirements)
getMemoryRequirementsBinded :: forall sd sm sib (fos :: ImageBufferArg).
D sd
-> ImageBufferBinded sm sib fos
-> IO (Either AlgnSize Requirements)
getMemoryRequirementsBinded (Device.D D
dv) = \case
	BufferBinded (Buffer.Binded PL Length objs
_ B
b) -> Requirements -> Either AlgnSize Requirements
forall a b. b -> Either a b
Right (Requirements -> Either AlgnSize Requirements)
-> IO Requirements -> IO (Either AlgnSize Requirements)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D -> B -> IO Requirements
Buffer.M.getMemoryRequirements D
dv B
b
	ImageBinded (Image.Binded I
i) -> Requirements -> Either AlgnSize Requirements
forall a b. b -> Either a b
Right (Requirements -> Either AlgnSize Requirements)
-> IO Requirements -> IO (Either AlgnSize Requirements)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D -> I -> IO Requirements
Image.M.getMemoryRequirements D
dv I
i
	RawBinded Size
algn Size
sz -> Either AlgnSize Requirements -> IO (Either AlgnSize Requirements)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AlgnSize Requirements -> IO (Either AlgnSize Requirements))
-> Either AlgnSize Requirements
-> IO (Either AlgnSize Requirements)
forall a b. (a -> b) -> a -> b
$ AlgnSize -> Either AlgnSize Requirements
forall a b. a -> Either a b
Left (Size
algn, Size
sz)

-- ADJUST OFFSET AND GET SIZE

adjustOffsetSize :: Device.D sd -> ImageBuffer sib ibarg -> Device.M.Size ->
	IO (Device.M.Size, Device.M.Size)
adjustOffsetSize :: forall sd sib (ibarg :: ImageBufferArg).
D sd -> ImageBuffer sib ibarg -> Size -> IO AlgnSize
adjustOffsetSize D sd
dv ImageBuffer sib ibarg
ib Size
ost = ((Either AlgnSize Requirements -> AlgnSize)
-> IO (Either AlgnSize Requirements) -> IO AlgnSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D sd -> ImageBuffer sib ibarg -> IO (Either AlgnSize Requirements)
forall sd sib (fos :: ImageBufferArg).
D sd -> ImageBuffer sib fos -> IO (Either AlgnSize Requirements)
getMemoryRequirements D sd
dv ImageBuffer sib ibarg
ib) \case
	Right Requirements
rs -> (
		Size -> Size -> Size
adjust (Requirements -> Size
Memory.M.requirementsAlignment Requirements
rs) Size
ost,
		Requirements -> Size
Memory.M.requirementsSize Requirements
rs )
	Left (Size
algn, Size
sz) -> (Size -> Size -> Size
adjust Size
algn Size
ost, Size
sz)

adjustOffsetSizeBinded :: Device.D sd -> ImageBufferBinded sm sib ibarg ->
	Device.M.Size -> IO (Device.M.Size, Device.M.Size)
adjustOffsetSizeBinded :: forall sd sm sib (ibarg :: ImageBufferArg).
D sd -> ImageBufferBinded sm sib ibarg -> Size -> IO AlgnSize
adjustOffsetSizeBinded D sd
dv ImageBufferBinded sm sib ibarg
ib Size
ost = ((Either AlgnSize Requirements -> AlgnSize)
-> IO (Either AlgnSize Requirements) -> IO AlgnSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D sd
-> ImageBufferBinded sm sib ibarg
-> IO (Either AlgnSize Requirements)
forall sd sm sib (fos :: ImageBufferArg).
D sd
-> ImageBufferBinded sm sib fos
-> IO (Either AlgnSize Requirements)
getMemoryRequirementsBinded D sd
dv ImageBufferBinded sm sib ibarg
ib) \case
	Right Requirements
rs -> (
		Size -> Size -> Size
adjust (Requirements -> Size
Memory.M.requirementsAlignment Requirements
rs) Size
ost,
		Requirements -> Size
Memory.M.requirementsSize Requirements
rs )
	Left (Size
algn, Size
sz) -> (Size -> Size -> Size
adjust Size
algn Size
ost, Size
sz)

adjust :: Device.M.Size -> Device.M.Size -> Device.M.Size
adjust :: Size -> Size -> Size
adjust Size
algn Size
ost = ((Size
ost Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1) Size -> Size -> Size
forall a. Integral a => a -> a -> a
`div` Size
algn Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
algn

-- ALIGNMENTS

class Alignments (ibs :: [(Type, ImageBufferArg)]) where
	alignments :: [Maybe Device.M.Size]

instance Alignments '[] where alignments :: [Maybe Size]
alignments = []

instance Alignments ibs => Alignments ('(_s, 'ImageArg _nm _fmt) ': ibs) where
	alignments :: [Maybe Size]
alignments = Maybe Size
forall a. Maybe a
Nothing Maybe Size -> [Maybe Size] -> [Maybe Size]
forall a. a -> [a] -> [a]
: forall (ibs :: [(*, ImageBufferArg)]).
Alignments ibs =>
[Maybe Size]
alignments @ibs

instance (VObj.WholeAlign objs, Alignments ibs) =>
	Alignments ('(_s, 'BufferArg _nm objs) ': ibs) where
	alignments :: [Maybe Size]
alignments = Size -> Maybe Size
forall a. a -> Maybe a
Just (forall (objs :: [O]). WholeAlign objs => Size
VObj.wholeAlign @objs) Maybe Size -> [Maybe Size] -> [Maybe Size]
forall a. a -> [a] -> [a]
: forall (ibs :: [(*, ImageBufferArg)]).
Alignments ibs =>
[Maybe Size]
alignments @ibs

instance Alignments ibs => Alignments ('(_s, 'RawArg) ': ibs) where
	alignments :: [Maybe Size]
alignments = Maybe Size
forall a. Maybe a
Nothing Maybe Size -> [Maybe Size] -> [Maybe Size]
forall a. a -> [a] -> [a]
: forall (ibs :: [(*, ImageBufferArg)]).
Alignments ibs =>
[Maybe Size]
alignments @ibs

-- OBJECT LENGTH

class ObjectLength (nm :: Symbol) (obj :: VObj.O) ibargs where
	objectLength' :: HeteroParList.PL (U2 ImageBuffer) ibargs ->
		VObj.Length obj

instance VObj.LengthOf obj objs =>
	ObjectLength nm obj ('(sib, 'BufferArg nm objs) ': ibargs) where
	objectLength' :: PL (U2 ImageBuffer) ('(sib, 'BufferArg nm objs) : ibargs)
-> Length obj
objectLength' (U2 (Buffer (Buffer.B PL Length objs
lns B
_)) :** PL (U2 ImageBuffer) ss1
_) =
		forall (obj :: O) (objs :: [O]).
LengthOf obj objs =>
PL Length objs -> Length obj
VObj.lengthOf @obj PL Length objs
lns

instance {-# OVERLAPPABLE #-} ObjectLength nm obj ibargs =>
	ObjectLength nm obj (ibarg ': ibargs) where
	objectLength' :: PL (U2 ImageBuffer) (ibarg : ibargs) -> Length obj
objectLength' (U2 ImageBuffer s
_ :** PL (U2 ImageBuffer) ss1
lns) = forall (nm :: Symbol) (obj :: O) (ibargs :: [(*, ImageBufferArg)]).
ObjectLength nm obj ibargs =>
PL (U2 ImageBuffer) ibargs -> Length obj
objectLength' @nm @obj PL (U2 ImageBuffer) ss1
lns

-- RAW OFFSET

class RawOffsetToOffset ibargs (n :: Nat) where
	rawOffsetToOffset :: Device.Size -> Device.D sd ->
		HPList.PL (U2 ImageBuffer) ibargs -> RawOffset n ->
		IO Device.Size

instance RawOffsetToOffset ('(sr, RawArg) ': ibargs) 0 where
	rawOffsetToOffset :: forall sd.
Size
-> D sd
-> PL (U2 ImageBuffer) ('(sr, 'RawArg) : ibargs)
-> RawOffset 0
-> IO Size
rawOffsetToOffset Size
ost0 D sd
_ PL (U2 ImageBuffer) ('(sr, 'RawArg) : ibargs)
_ (RawOffset Size
o) = Size -> IO Size
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> IO Size) -> Size -> IO Size
forall a b. (a -> b) -> a -> b
$ Size
ost0 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
o

instance {-# OVERLAPPABLE #-} RawOffsetToOffset ibargs (n - 1) =>
	RawOffsetToOffset ('(sr, RawArg) ': ibargs) n where
	rawOffsetToOffset :: forall sd.
Size
-> D sd
-> PL (U2 ImageBuffer) ('(sr, 'RawArg) : ibargs)
-> RawOffset n
-> IO Size
rawOffsetToOffset Size
ost0 D sd
dv (U2 ImageBuffer s1 s2
ib :** PL (U2 ImageBuffer) ss1
ibs) (RawOffset Size
o) = do
		(ost', sz) <- D sd -> ImageBuffer s1 s2 -> Size -> IO AlgnSize
forall sd sib (ibarg :: ImageBufferArg).
D sd -> ImageBuffer sib ibarg -> Size -> IO AlgnSize
adjustOffsetSize D sd
dv ImageBuffer s1 s2
ib Size
ost0
		rawOffsetToOffset (ost' + sz) dv ibs (RawOffset @(n - 1) o)

instance {-# OVERLAPPABLE #-} RawOffsetToOffset ibargs n =>
	RawOffsetToOffset (ibarg ': ibargs) n where
	rawOffsetToOffset :: forall sd.
Size
-> D sd
-> PL (U2 ImageBuffer) (ibarg : ibargs)
-> RawOffset n
-> IO Size
rawOffsetToOffset Size
ost0 D sd
dv (U2 ImageBuffer s1 s2
ib :** PL (U2 ImageBuffer) ss1
ibs) RawOffset n
ro = do
		(ost', sz) <- D sd -> ImageBuffer s1 s2 -> Size -> IO AlgnSize
forall sd sib (ibarg :: ImageBufferArg).
D sd -> ImageBuffer sib ibarg -> Size -> IO AlgnSize
adjustOffsetSize D sd
dv ImageBuffer s1 s2
ib Size
ost0
		rawOffsetToOffset (ost' + sz) dv ibs ro

newtype RawOffset (n :: Nat) = RawOffset Device.Size deriving (Int -> RawOffset n -> ShowS
[RawOffset n] -> ShowS
RawOffset n -> String
(Int -> RawOffset n -> ShowS)
-> (RawOffset n -> String)
-> ([RawOffset n] -> ShowS)
-> Show (RawOffset n)
forall (n :: Nat). Int -> RawOffset n -> ShowS
forall (n :: Nat). [RawOffset n] -> ShowS
forall (n :: Nat). RawOffset n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (n :: Nat). Int -> RawOffset n -> ShowS
showsPrec :: Int -> RawOffset n -> ShowS
$cshow :: forall (n :: Nat). RawOffset n -> String
show :: RawOffset n -> String
$cshowList :: forall (n :: Nat). [RawOffset n] -> ShowS
showList :: [RawOffset n] -> ShowS
Show, Integer -> RawOffset n
RawOffset n -> RawOffset n
RawOffset n -> RawOffset n -> RawOffset n
(RawOffset n -> RawOffset n -> RawOffset n)
-> (RawOffset n -> RawOffset n -> RawOffset n)
-> (RawOffset n -> RawOffset n -> RawOffset n)
-> (RawOffset n -> RawOffset n)
-> (RawOffset n -> RawOffset n)
-> (RawOffset n -> RawOffset n)
-> (Integer -> RawOffset n)
-> Num (RawOffset n)
forall (n :: Nat). Integer -> RawOffset n
forall (n :: Nat). RawOffset n -> RawOffset n
forall (n :: Nat). RawOffset n -> RawOffset n -> RawOffset n
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: forall (n :: Nat). RawOffset n -> RawOffset n -> RawOffset n
+ :: RawOffset n -> RawOffset n -> RawOffset n
$c- :: forall (n :: Nat). RawOffset n -> RawOffset n -> RawOffset n
- :: RawOffset n -> RawOffset n -> RawOffset n
$c* :: forall (n :: Nat). RawOffset n -> RawOffset n -> RawOffset n
* :: RawOffset n -> RawOffset n -> RawOffset n
$cnegate :: forall (n :: Nat). RawOffset n -> RawOffset n
negate :: RawOffset n -> RawOffset n
$cabs :: forall (n :: Nat). RawOffset n -> RawOffset n
abs :: RawOffset n -> RawOffset n
$csignum :: forall (n :: Nat). RawOffset n -> RawOffset n
signum :: RawOffset n -> RawOffset n
$cfromInteger :: forall (n :: Nat). Integer -> RawOffset n
fromInteger :: Integer -> RawOffset n
Num)