{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}
{-# LANGUAGE GADTs, TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.QueryPool (

	-- * CREATE

	create, Q, CreateInfo(..),

	-- * GET RESULTS

	getResults, QueryType, PipelineStatistics(..), Timestamp(..),

	M.Availability(..)

	) where

import Foreign.Storable
import Foreign.Storable.PeekPoke
import Control.Exception
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.TypeLevel.Tuple.Uncurry
import Data.Kind
import Data.Word

import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks
import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks
import Gpu.Vulkan.PhysicalDevice qualified as PhysicalDevice
import Gpu.Vulkan.Device.Type qualified as Device
import Gpu.Vulkan.Query qualified as Q
import Gpu.Vulkan.QueryPool.Type
import Gpu.Vulkan.QueryPool.Middle qualified as M

-- CREATE

create :: (
	WithPoked (TMaybe.M mn), QueryType tp,
	AllocationCallbacks.ToMiddle mac ) =>
	Device.D sd -> CreateInfo mn tp ->
	TPMaybe.M (U2 AllocationCallbacks.A) mac ->
	(forall s . Q s tp -> IO a) -> IO a
create :: forall (mn :: Maybe (*)) (tp :: Bool -> *) (mac :: Maybe (*, *)) sd
       a.
(WithPoked (M mn), QueryType tp, ToMiddle mac) =>
D sd
-> CreateInfo mn tp
-> M (U2 A) mac
-> (forall s. Q s tp -> IO a)
-> IO a
create (Device.D D
dv) CreateInfo mn tp
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 s. Q s tp -> IO a
f = IO Q -> (Q -> IO ()) -> (Q -> 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 Q
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO Q
M.create D
dv (CreateInfo mn tp -> CreateInfo mn
forall (n :: Maybe (*)) (tp :: Bool -> *).
QueryType tp =>
CreateInfo n tp -> CreateInfo n
createInfoToMiddle CreateInfo mn tp
ci) M A (Snd mac)
macc)
	(\Q
qp -> D -> Q -> M A (Snd mac) -> IO ()
forall (md :: Maybe (*)). D -> Q -> M A md -> IO ()
M.destroy D
dv Q
qp M A (Snd mac)
macc) (Q Any tp -> IO a
forall s. Q s tp -> IO a
f (Q Any tp -> IO a) -> (Q -> Q Any tp) -> Q -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> Q Any tp
forall sq (tp :: Bool -> *). Q -> Q sq tp
Q)

data CreateInfo mn (tp :: Bool -> Type) = CreateInfo {
	forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> CreateFlags
createInfoFlags :: M.CreateFlags,
	forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> Word32
createInfoQueryCount :: Q.Count,
	forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> PipelineStatisticFlags
createInfoPipelineStatistics :: Q.PipelineStatisticFlags }

deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn tp)

createInfoToMiddle ::
	forall n tp . QueryType tp => CreateInfo n tp -> M.CreateInfo n
createInfoToMiddle :: forall (n :: Maybe (*)) (tp :: Bool -> *).
QueryType tp =>
CreateInfo n tp -> CreateInfo n
createInfoToMiddle CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> M mn
createInfoNext = M n
mnxt,
	createInfoFlags :: forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> CreateFlags
createInfoFlags = CreateFlags
flgs,
	createInfoQueryCount :: forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> Word32
createInfoQueryCount = Word32
qc,
	createInfoPipelineStatistics :: forall (mn :: Maybe (*)) (tp :: Bool -> *).
CreateInfo mn tp -> PipelineStatisticFlags
createInfoPipelineStatistics = PipelineStatisticFlags
ps } = M.CreateInfo {
	createInfoNext :: M n
M.createInfoNext = M n
mnxt,
	createInfoFlags :: CreateFlags
M.createInfoFlags = CreateFlags
flgs,
	createInfoQueryType :: Type
M.createInfoQueryType = forall (qt :: Bool -> *). QueryType qt => Type
queryType @tp,
	createInfoQueryCount :: Word32
M.createInfoQueryCount = Word32
qc,
	createInfoPipelineStatistics :: PipelineStatisticFlags
M.createInfoPipelineStatistics = PipelineStatisticFlags
ps }

-- GET RESULTS

getResults :: forall sd sq av tp w64 . (
	QueryType tp,
	Storable (M.W32W64 w64), M.W32W64Tools w64,
	M.AvailabilityTools av (M.W32W64 w64) ) =>
	PhysicalDevice.P ->
	Device.D sd -> Q sq tp -> Q.First -> Q.Count -> Q.ResultFlags ->
	IO [M.Availability av (tp w64)]
getResults :: forall sd sq (av :: Bool) (tp :: Bool -> *) (w64 :: Bool).
(QueryType tp, Storable (W32W64 w64), W32W64Tools w64,
 AvailabilityTools av (W32W64 w64)) =>
P
-> D sd
-> Q sq tp
-> Word32
-> Word32
-> ResultFlags
-> IO [Availability av (tp w64)]
getResults P
pd (Device.D D
dv) (Q Q
qp) Word32
fq Word32
qc ResultFlags
flgs = do
	a <- forall (qt :: Bool -> *). QueryType qt => P -> IO (QueryArg qt)
getQueryArg @tp P
pd
	((fromWord a <$>) <$>) <$> M.getResults dv qp fq qc flgs

class QueryType (qt :: Bool -> Type) where
	type QueryArg qt
	queryType :: Q.Type
	fromWord :: QueryArg qt -> M.W32W64 w64 -> qt w64
	getQueryArg :: PhysicalDevice.P -> IO (QueryArg qt)

-- Pipeline Statistics

instance QueryType PipelineStatistics where
	type QueryArg PipelineStatistics = ()
	queryType :: Type
queryType = Type
Q.TypePipelineStatistics
	fromWord :: forall (w64 :: Bool).
QueryArg PipelineStatistics -> W32W64 w64 -> PipelineStatistics w64
fromWord () = W32W64 w64 -> PipelineStatistics w64
forall (w64 :: Bool). W32W64 w64 -> PipelineStatistics w64
pipelineStatisticsFromWord
	getQueryArg :: P -> IO (QueryArg PipelineStatistics)
getQueryArg P
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

data PipelineStatistics (w64 :: Bool) where
	PipelineStatistics32 :: Word32 -> PipelineStatistics 'False
	PipelineStatistics64 :: Word64 -> PipelineStatistics 'True

deriving instance Show (PipelineStatistics w64)

pipelineStatisticsFromWord :: M.W32W64 w64 -> PipelineStatistics w64
pipelineStatisticsFromWord :: forall (w64 :: Bool). W32W64 w64 -> PipelineStatistics w64
pipelineStatisticsFromWord = \case
	M.W32 Word32
w -> Word32 -> PipelineStatistics 'False
PipelineStatistics32 Word32
w; M.W64 Word64
w -> Word64 -> PipelineStatistics 'True
PipelineStatistics64 Word64
w

-- Timestamp

data Timestamp w64 where
	Timestamp32 :: {
		Timestamp 'False -> Float
timestampPeriod32 :: Float,
		Timestamp 'False -> Word32
timestampW32 :: Word32 } -> Timestamp 'False
	Timestamp64 :: {
		Timestamp 'True -> Float
timestampPeriod64 :: Float,
		Timestamp 'True -> Word64
timestampW64 :: Word64 } -> Timestamp 'True

instance Show (Timestamp w64) where
	show :: Timestamp w64 -> String
show = \case
		Timestamp32 Float
p Word32
w ->
			forall a. Show a => a -> String
show @Double (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
p Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"ns"
		Timestamp64 Float
p Word64
w ->
			forall a. Show a => a -> String
show @Double (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
p Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"ns"

instance QueryType Timestamp where
	type QueryArg Timestamp = Float
	queryType :: Type
queryType = Type
Q.TypeTimestamp
	fromWord :: forall (w64 :: Bool).
QueryArg Timestamp -> W32W64 w64 -> Timestamp w64
fromWord QueryArg Timestamp
p = \case
		M.W32 Word32
w -> Float -> Word32 -> Timestamp 'False
Timestamp32 Float
QueryArg Timestamp
p Word32
w; M.W64 Word64
w -> Float -> Word64 -> Timestamp 'True
Timestamp64 Float
QueryArg Timestamp
p Word64
w
	getQueryArg :: P -> IO (QueryArg Timestamp)
getQueryArg P
pd = do
		lmts <- Properties -> Limits
PhysicalDevice.propertiesLimits
			(Properties -> Limits) -> IO Properties -> IO Limits
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P -> IO Properties
PhysicalDevice.getProperties P
pd
		pure $ PhysicalDevice.limitsTimestampPeriod lmts