{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.Vulkan.Marshal.Create.DataFrame
( setVec, getVec
, fillDataFrame, withDFPtr, setDFRef
) where
import Foreign.Storable
import GHC.Base
import GHC.Ptr (Ptr (..))
import Graphics.Vulkan
import Graphics.Vulkan.Marshal.Create
import Graphics.Vulkan.Marshal.Internal
import Numeric.DataFrame
import Numeric.DataFrame.IO
import Numeric.Dimensions
import Numeric.PrimBytes
setVec :: forall fname x t
. ( FieldType fname x ~ t
, PrimBytes t
, KnownDim (FieldArrayLength fname x)
, CanWriteFieldArray fname x
)
=> Vector t (FieldArrayLength fname x) -> CreateVkStruct x '[fname] ()
setVec v
| Dict <- inferKnownBackend @t @'[FieldArrayLength fname x]
= unsafeIOCreate $ \p -> pokeByteOff p (fieldOffset @fname @x) v
getVec :: forall fname x t
. ( FieldType fname x ~ t
, PrimBytes t
, KnownDim (FieldArrayLength fname x)
, CanReadFieldArray fname x
)
=> x -> Vector t (FieldArrayLength fname x)
getVec x
| ba <- unsafeByteArray x
, xaddr <- unsafeAddr x
, baddr <- byteArrayContents# ba
, I# off <- fieldOffset @fname @x
, Dict <- inferKnownBackend @t @'[FieldArrayLength fname x]
= fromBytes (minusAddr# xaddr baddr +# off) ba
instance VulkanMarshal (VkStruct a) => PrimBytes (VkStruct a) where
type PrimFields (VkStruct a) = '[]
byteSize a = case sizeOf a of (I# s) -> s
{-# INLINE byteSize #-}
byteAlign a = case alignment a of (I# n) -> n
{-# INLINE byteAlign #-}
byteOffset a = minusAddr# (unsafeAddr a)
(byteArrayContents# (unsafeByteArray a))
{-# INLINE byteOffset #-}
getBytes = unsafeByteArray
{-# INLINE getBytes #-}
fromBytes = unsafeFromByteArrayOffset
{-# INLINE fromBytes #-}
readBytes mba off = unsafeCoerce# (newVkData @(VkStruct a) f)
where
f :: Ptr (VkStruct a) -> IO ()
f (Ptr addr) = IO $ \s ->
(# copyMutableByteArrayToAddr# (unsafeCoerce# mba)
off addr (byteSize @(VkStruct a) undefined) s
, () #)
writeBytes mba off a
= copyAddrToByteArray# (unsafeAddr a) mba off (byteSize @(VkStruct a) undefined)
readAddr addr = unsafeCoerce# (peek (Ptr addr) :: IO (VkStruct a))
writeAddr a addr s
= case unsafeCoerce# (poke (Ptr addr) a :: IO ()) s of
(# s', () #) -> s'
byteFieldOffset _ _ = negateInt# 1#
withDFPtr :: forall (a :: Type) (ds :: [Nat]) (b :: Type)
. (PrimBytes a, Dimensions ds)
=> DataFrame a ds -> (Ptr a -> IO b) -> IO b
withDFPtr x k
| Dict <- inferKnownBackend @a @ds
, ba <- getBytesPinned x = do
b <- k (Ptr (byteArrayContents# ba `plusAddr#` byteOffset x))
IO $ \s -> (# touch# ba s, () #)
return b
setDFRef :: forall fname x a (ds :: [Nat])
. ( CanWriteField fname x
, FieldType fname x ~ Ptr a
, PrimBytes a, Dimensions ds
)
=> DataFrame a ds -> CreateVkStruct x '[fname] ()
setDFRef v
| Dict <- inferKnownBackend @a @ds
, ba <- getBytesPinned v
, addr <- byteArrayContents# ba `plusAddr#` byteOffset v
= let f :: Ptr x -> IO ( ([Ptr ()],[IO ()]) , ())
f p = (,) ([],[IO $ \s -> (# touch# ba s, () #)])
<$> writeField @fname @x p (Ptr addr)
in unsafeCoerce# f
fillDataFrame :: forall a
. PrimBytes a
=> Word -> (Ptr a -> IO ()) -> IO (Vector a (XN 0))
fillDataFrame n k
| Dx (D :: Dim n) <- someDimVal n
, Dict <- inferKnownBackend @a @'[n]
= do
mdf <- newPinnedDataFrame
withDataFramePtr mdf k
XFrame <$> unsafeFreezeDataFrame @a @'[n] mdf
fillDataFrame _ _ = error "fillDataFrame: impossible combination of arguments."