{-# 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               #-}
-- | This module is not part of auto-generated code based on vk.xml.
--   Instead, it is hand-written to provide common types and classes.
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
    -- * Type-indexed access to struct members
  , 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
    -- * Type-level info about Structs
  , VulkanStruct (..), VulkanField (..), VulkanFields (..), KnownBool (..)
  , FieldMeta (..), StructMeta (..)
    -- * Re-exported functions from 'Foreign.ForeignPtr'
  , mallocForeignPtr, withForeignPtr, addForeignPtrFinalizer
    -- * Re-exported common types
  , Int8, Int16, Int32, Int64
  , Word8, Word16, Word32, Word64
  , Ptr, FunPtr, Void, CString
  , CInt (..), CSize (..), CChar (..), CWchar (..), CULong (..)
    -- * Utilities for string types
  , 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


-- | Distinguish single bits and bitmasks in vulkan flags
data FlagType = FlagMask | FlagBit

-- | Vulkan flags type that can have multiple bits set.
type FlagMask = 'FlagMask
-- | Vulkan single bit flag value.
type FlagBit  = 'FlagBit

-- | A synonym for `zeroBits`
pattern VK_ZERO_FLAGS :: Bits a => a
pattern VK_ZERO_FLAGS <- (popCount -> 0)
  where
    VK_ZERO_FLAGS = zeroBits

-- | Convert a single bit (@XxxBits@) to a bitmask (@XxxFlags@)
bitToMask :: Coercible (x FlagBit) (x FlagMask) => x FlagBit -> x FlagMask
bitToMask = coerce

-- | List all set bits of a bitmask (@XxxFlags@) in the increasing order.
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'


-- | ===== @VK_DEFINE_NON_DISPATCHABLE_HANDLE@
-- Non-dispatchable handles are represented as `VkPtr`
--
-- Represented as `Word64`
--
-- >
-- > #if !defined(VK_DEFINE_NON_DISPATCHABLE_HANDLE)
-- > #if defined(__LP64__) || defined(_WIN64) || (defined(__x86_64__) && !defined(__ILP32__) ) || defined(_M_X64) || defined(__ia64) || defined (_M_IA64) || defined(__aarch64__) || defined(__powerpc64__)
-- >         #define VK_DEFINE_NON_DISPATCHABLE_HANDLE(object) typedef struct object##_T *object;
-- > #else
-- >         #define VK_DEFINE_NON_DISPATCHABLE_HANDLE(object) typedef uint64_t object;
-- > #endif
-- > #endif
-- >
--
newtype VkPtr a = VkPtr Word64
  deriving (Eq, Ord, Show, Storable)
type role VkPtr phantom


-- | Unify dispatchable and non-dispatchable vulkan pointer types.
--
--  Dispatchable handles are represented as `Ptr`.
--
--  Non-dispatchable handles are represented as `VkPtr`.
--
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 #-}

-- | Null pointer (either dispatchable or non-dispatchable)
pattern VK_NULL :: (Eq (ptr a), VulkanPtr ptr) => ptr a
pattern VK_NULL <- (isNullPtr -> True)
  where VK_NULL = vkNullPtr

-- | >
--   > #define VK_NULL_HANDLE 0
--   >
pattern VK_NULL_HANDLE :: (Eq (ptr a), VulkanPtr ptr) => ptr a
pattern VK_NULL_HANDLE = VK_NULL


-- | Run some operation with a pointer to vulkan structure.
--
--   Should be used with care:
--     the structure pretends to be immutable, so it is better to only read
--     from the pointed memory area, not to write.
--     If an action needs to write something to the pointer, use `newVkData`.
withPtr :: VulkanMarshal a => a -> (Ptr a -> IO b) -> IO b
withPtr x k = do
  b <- k (unsafePtr x)
  touchVkData x
  return b

-- | Fill all bytes to zero getting data size from `Storable` instance.
clearStorable :: Storable a => Ptr a -> IO ()
clearStorable p = fillBytes p 0 (sizeOf $ unptr p)
  where
    unptr :: Ptr b -> b
    unptr ~_ = undefined