{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}
module Graphics.Vulkan.Marshal
( FlagType (..), FlagMask, FlagBit
, bitToMask, maskToBits
, VulkanMarshal (..)
, newVkData, mallocVkData, mallocVkDataArray, unsafePtr
, fromForeignPtr, toForeignPtr, toPlainForeignPtr, touchVkData
, VulkanPtr (..)
, VkPtr (..)
, pattern VK_ZERO_FLAGS
, pattern VK_NULL_HANDLE, pattern VK_NULL
, clearStorable, withPtr
, StructFields, CUnionType, ReturnedOnly, StructExtends
, StructFieldNames, HasField, FieldRep, FieldType
, FieldOptional, FieldOffset
, FieldIsArray, FieldArrayLength
, CanReadField, CanWriteField
, CanReadFieldArray, CanWriteFieldArray
, fieldOptional, fieldOffset, fieldArrayLength
, getField, readField, writeField
, getFieldArrayUnsafe, readFieldArrayUnsafe, writeFieldArrayUnsafe
, getFieldArray, readFieldArray, writeFieldArray
, IndexInBounds
, VulkanStruct (..), VulkanField (..), VulkanFields (..), KnownBool (..)
, FieldMeta (..), StructMeta (..)
, mallocForeignPtr, withForeignPtr, addForeignPtrFinalizer
, Int8, Int16, Int32, Int64
, Word8, Word16, Word32, Word64
, Ptr, FunPtr, Void, CString
, CInt (..), CSize (..), CChar (..), CWchar (..), CULong (..)
, withCStringField, unsafeCStringField
, getStringField, readStringField, writeStringField
, cmpCStrings, cmpCStringsN
) where
import Data.Bits (Bits (..))
import Data.Coerce
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Void (Void)
import Data.Word (Word16, Word32, Word64, Word8)
import Foreign.C.String (CString)
import Foreign.C.Types (CChar (..), CInt (..), CSize (..), CULong (..),
CWchar (..))
import Foreign.ForeignPtr (addForeignPtrFinalizer, mallocForeignPtr,
withForeignPtr)
import Foreign.Marshal.Utils (fillBytes)
import Foreign.Ptr (FunPtr, nullPtr)
import Foreign.Storable
import GHC.Ptr (Ptr (..))
import Graphics.Vulkan.Marshal.Internal
data FlagType = FlagMask | FlagBit
type FlagMask = 'FlagMask
type FlagBit = 'FlagBit
pattern VK_ZERO_FLAGS :: Bits a => a
pattern VK_ZERO_FLAGS <- (popCount -> 0)
where
VK_ZERO_FLAGS = zeroBits
bitToMask :: Coercible (x FlagBit) (x FlagMask) => x FlagBit -> x FlagMask
bitToMask = coerce
maskToBits :: (Bits (x FlagMask), Coercible (x FlagBit) (x FlagMask))
=> x FlagMask -> [x FlagBit]
maskToBits x = go (popCount x) (bit 0)
where
zero = zeroBits
go 0 _ = []
go n i = let b = i .&. x
i' = unsafeShiftL i 1
in if b == zero
then go n i'
else coerce b : go (n-1) i'
newtype VkPtr a = VkPtr Word64
deriving (Eq, Ord, Show, Storable)
type role VkPtr phantom
class VulkanPtr ptr where
vkNullPtr :: ptr a
instance VulkanPtr Ptr where
vkNullPtr = nullPtr
{-# INLINE vkNullPtr #-}
instance VulkanPtr VkPtr where
vkNullPtr = VkPtr 0
{-# INLINE vkNullPtr #-}
isNullPtr :: (Eq (ptr a), VulkanPtr ptr) => ptr a -> Bool
isNullPtr = (vkNullPtr ==)
{-# INLINE isNullPtr #-}
pattern VK_NULL :: (Eq (ptr a), VulkanPtr ptr) => ptr a
pattern VK_NULL <- (isNullPtr -> True)
where VK_NULL = vkNullPtr
pattern VK_NULL_HANDLE :: (Eq (ptr a), VulkanPtr ptr) => ptr a
pattern VK_NULL_HANDLE = VK_NULL
withPtr :: VulkanMarshal a => a -> (Ptr a -> IO b) -> IO b
withPtr x k = do
b <- k (unsafePtr x)
touchVkData x
return b
clearStorable :: Storable a => Ptr a -> IO ()
clearStorable p = fillBytes p 0 (sizeOf $ unptr p)
where
unptr :: Ptr b -> b
unptr ~_ = undefined