{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# 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 UnboxedTuples              #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE UndecidableSuperClasses    #-}
{-# LANGUAGE UnliftedFFITypes           #-}
-- | This module is not part of auto-generated code based on vk.xml.
--   Instead, it is hand-written to provide common types and classes.
--
--   DANGER!
--   This is an internal module; it can change a lot between package versions;
--   it provides low-level functions, most of which have user-friendly analogues.
module Graphics.Vulkan.Marshal.Internal
  ( VkStruct (..), unsafeFromByteArrayOffset
  , VulkanMarshal (..)
  , newVkData, mallocVkData, mallocVkDataArray, unsafePtr
  , fromForeignPtr, toForeignPtr, toPlainForeignPtr, touchVkData
    -- * 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 (..)
    -- * Utilities for string types
  , withCStringField, unsafeCStringField
  , getStringField, readStringField, writeStringField
  , cmpCStrings, cmpCStringsN
  ) where


import Data.Kind             (Constraint, Type)
import Data.Type.Equality
import Foreign.C.String      (CString, peekCString)
import Foreign.C.Types       (CChar, CInt (..), CSize (..))
import Foreign.ForeignPtr    (ForeignPtr, newForeignPtr_)
import Foreign.Marshal.Array (pokeArray0)
import Foreign.Ptr           (plusPtr)
import Foreign.Storable
import GHC.Base              (Addr#, ByteArray#, IO (..), Int (..), Int#,
                              byteArrayContents#, copyAddrToByteArray#, eqAddr#,
                              isTrue#, minusAddr#, newAlignedPinnedByteArray#,
                              plusAddr#, touch#,
                              unsafeFreezeByteArray#, (*#), (+#), (>=#))
import GHC.Exts              (Proxy#, proxy#, unsafeCoerce#)
import GHC.ForeignPtr        (ForeignPtr (..), ForeignPtrContents (..))
import GHC.Ptr               (Ptr (..))
import GHC.TypeLits
import System.IO.Unsafe      (unsafeDupablePerformIO)
import Unsafe.Coerce         (unsafeCoerce)



{- | Internal representation of all Vulkan structures:
     a pinned byte array and an address pointing to an area in this array.
 -}
data VkStruct a = VkStruct
  { unsafeAddr      :: Addr#
    -- ^ Get address of vulkan structure.
    --   Note, the address is only valid as long as a given vulkan structure exists.
    --   Structures created with newVkData are stored in pinned byte arrays,
    --   so their memory is maintained by Haskell GC.
  , unsafeByteArray :: ByteArray#
    -- ^ Get a @ByteArray#@ that keeps the data.
    --
    --   Note, the data structure does not necessarily starts at zero offset.
  }

-- | Get the type parameter of a `VkStruct`.
type family VkStruct' (a :: Type) :: Type where
    VkStruct' (VkStruct a) = a

-- | This type must be a `VkStruct`.
type IsVkStruct a = a ~ VkStruct (VkStruct' a)

-- | Combine a vulkan structure from ByteArray and an offset in this array.
unsafeFromByteArrayOffset :: Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset off b
  = VkStruct (plusAddr# (byteArrayContents# b) off) b
{-# INLINE unsafeFromByteArrayOffset #-}



{- |
@FieldMeta fieldName fieldType optional byteOffset length canRead canWrite@
represents a Vulkan structure field at the type level.
 -}
data FieldMeta
  = FieldMeta Symbol Type Bool Nat Nat Bool Bool

{- |
@StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends@
represents a Vulkan structure at the type level.
 -}
data StructMeta
  = StructMeta Symbol Type Nat Nat [FieldMeta] Bool Bool [Type]

-- | This class give a term-level boolean associated with a type-level boolean.
--
--   The same as `KnownNat` for integers.
class KnownBool (b :: Bool) where
    boolSing :: Bool

instance KnownBool 'True  where boolSing = True
instance KnownBool 'False where boolSing = False

class (Show (FType m), Storable (FType m))
     => VulkanField (m :: FieldMeta) where
    type FName m       :: Symbol
    type FType m       :: Type
    type FOptional m   :: Bool
    type FByteOffset m :: Nat
    type FLength m     :: Nat
    type FCanRead m    :: Bool
    type FCanWrite m   :: Bool
    fName :: String
    fOptional :: Bool
    fByteOffset :: Int
    fLength :: Int
    fCanRead :: Bool
    fCanWrite :: Bool

instance ( KnownSymbol fieldName
         , Show t, Storable t
         , KnownBool   optional
         , KnownNat    byteOffset
         , KnownNat    length
         , KnownBool   canRead
         , KnownBool   canWrite
         ) => VulkanField ('FieldMeta fieldName t optional byteOffset length canRead canWrite) where
    type FName       ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = fieldName
    type FType       ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = t
    type FOptional   ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = optional
    type FByteOffset ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = byteOffset
    type FLength     ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = length
    type FCanRead    ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = canRead
    type FCanWrite   ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = canWrite
    fName       = symbolVal' @fieldName proxy#
    fOptional   = boolSing   @optional
    fByteOffset = fromInteger $ natVal' @byteOffset proxy#
    fLength     = fromInteger $ natVal' @length proxy#
    fCanRead    = boolSing   @canRead
    fCanWrite   = boolSing   @canWrite

type family GetFieldMeta (errMsg :: ErrorMessage) (fname :: Symbol) (ms :: [FieldMeta]) :: FieldMeta where
    GetFieldMeta _ n ('FieldMeta n t o b l r w ': _) = 'FieldMeta n t o b l r w
    GetFieldMeta e n (_ ': ms) = GetFieldMeta e n ms
    GetFieldMeta e n '[] = TypeError e

class VulkanFields (ms :: [FieldMeta]) where
    withField :: forall (fname :: Symbol) (r :: Type) (errMsg :: ErrorMessage)
               . KnownSymbol fname
              => Proxy# fname
              -> Proxy# errMsg
              -> (VulkanField (GetFieldMeta errMsg fname ms) => r) -> r
    enumerateFields :: forall  (a :: Type)
                     . (forall (m :: FieldMeta) . VulkanField m
                             => Proxy# m -> a -> a)
                    -> a -> a

instance VulkanFields '[] where
    withField _ _ _ = error "VulkanFields.withField: unreachable code (no such field guarded by type family)."
    enumerateFields _ = id

instance (VulkanField m, VulkanFields ms) => VulkanFields (m ': ms) where
    withField pName pErr f
      | symbolVal' pName == fName @m
      , Refl <- proofm  pName pErr = f
      | Refl <- proofms pName pErr = withField @ms pName pErr f
      where
        proofm :: Proxy# fname -> Proxy# errMsg
              -> (m :~: GetFieldMeta errMsg fname (m : ms))
        proofm _ = unsafeCoerce Refl
        proofms :: Proxy# fname -> Proxy# errMsg
                -> (GetFieldMeta errMsg fname ms :~: GetFieldMeta errMsg fname (m : ms))
        proofms _ = unsafeCoerce Refl
    enumerateFields k = k (proxy# :: Proxy# m) . enumerateFields @ms k


class VulkanFields (SFields m)
   => VulkanStruct (m :: StructMeta) where
    type SName m           :: Symbol
    type SType m           :: Type
    type SSize m           :: Nat
    type SAlign m          :: Nat
    type SFields m         :: [FieldMeta]
    type SIsUnion m        :: Bool
    type SIsReturnedOnly m :: Bool
    type SStructExtends m  :: [Type]
    sName           :: String
    sSize           :: Int
    sAlign          :: Int
    sIsUnion        :: Bool
    sIsReturnedOnly :: Bool

instance ( KnownSymbol structName
         , KnownNat size
         , KnownNat alignment
         , VulkanFields fields
         , KnownBool isUnion
         , KnownBool isReturnedOnly
         )
      => VulkanStruct
          ('StructMeta structName structType size alignment
                         fields isUnion isReturnedOnly structExtends) where
    type SName           ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = structName
    type SType           ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = structType
    type SSize           ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = size
    type SAlign          ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = alignment
    type SFields         ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = fields
    type SIsUnion        ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = isUnion
    type SIsReturnedOnly ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = isReturnedOnly
    type SStructExtends  ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = structExtends
    sName           = symbolVal' @structName proxy#
    sSize           = fromInteger $ natVal' @size proxy#
    sAlign          = fromInteger $ natVal' @alignment proxy#
    sIsUnion        = boolSing @isUnion
    sIsReturnedOnly = boolSing @isReturnedOnly


-- | Descriptions of all fields of a vulkan struct
type StructFields a = SFields (StructRep a)
-- | Whether this type is a C union.
--   Otherwise this is a C structure.
type CUnionType a = SIsUnion (StructRep a)
-- | Notes that this struct or union is going to be filled in by the API,
--   rather than an application filling it out and passing it to the API.
type ReturnedOnly a = SIsReturnedOnly (StructRep a)
-- | Comma-separated list of structures whose "pNext" can include this type.
type StructExtends a = SStructExtends (StructRep a)

-- | All Vulkan structures are stored as-is in byte arrays to avoid any overheads
--   for wrapping and unwrapping haskell values.
--   VulkanMarshal provides an interfaces to write and read these structures
--   in an imperative way.
class (VulkanStruct (StructRep a), IsVkStruct a)
     => VulkanMarshal a where
    type StructRep a :: StructMeta

-- | Allocate a pinned aligned byte array to keep vulkan data structure
--   and fill it using a foreign function.
--
--   Note, the function is supposed to use `newAlignedPinnedByteArray#`
--   and does not guarantee to fill memory with zeroes.
--   Use `clearStorable` to make sure all bytes are set to zero.
--
--   Note, the memory is managed by GHC, thus no need for freeing it manually.
newVkData :: forall a . VulkanMarshal a => (Ptr a -> IO ()) -> IO a
newVkData f
  | I# n <- sSize @(StructRep a)
  , I# a <- sAlign @(StructRep a)
  = IO
  (\s0 -> case newAlignedPinnedByteArray# n a s0 of
    (# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
      (# s2, ba #) -> case f (Ptr (byteArrayContents# ba)) of
        IO k -> case k s2 of
          (# s3, () #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
  )
{-# INLINE newVkData #-}

-- | Allocate a pinned aligned byte array to keep vulkan data structure.
--
--   Note, the function is supposed to use `newAlignedPinnedByteArray#`
--   and does not guarantee to fill memory with zeroes.
--   Use `clearStorable` to make sure all bytes are set to zero.
--
--   Note, the memory is managed by GHC, thus no need for freeing it manually.
mallocVkData :: forall a . VulkanMarshal a => IO a
mallocVkData
  | I# n <- sSize @(StructRep a)
  , I# a <- sAlign @(StructRep a)
  = IO
  (\s0 -> case newAlignedPinnedByteArray# n a s0 of
    (# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
      (# s2, ba #) -> (# s2, unsafeFromByteArrayOffset 0# ba #)
  )
{-# INLINE mallocVkData #-}

-- | Allocate a pinned aligned byte array to keep vulkan data structures.
--   Returned `Ptr a` points to the first element in the contiguous array of
--   returned structures. Returned list elements point to the same memory area.
--   This function is unsafe in two ways:
--
--     * Several structures are stored next to each other, with no gaps;
--       it would break its alignment if the size is not multiple of alignment.
--     * Returned pointer is not tracked by GHC as a reference to the managed
--       memory. Thus, the array can be GCed if all references to the returned
--       list are lost.
--
--   Note, the function is supposed to use `newAlignedPinnedByteArray#`
--   and does not guarantee to fill memory with zeroes.
--   Use `clearStorable` to make sure all bytes are set to zero.
--
--   Note, the memory is managed by GHC, thus no need for freeing it manually.
mallocVkDataArray :: forall a . VulkanMarshal a => Int -> IO (Ptr a, [a])
mallocVkDataArray (I# m)
  | I# n <- sSize @(StructRep a)
  , I# a <- sAlign @(StructRep a)
  , nm <- n *# m
  = IO
  (\s0 -> case newAlignedPinnedByteArray# nm a s0 of
    (# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
      (# s2, ba #) ->
        (# s2
        , ( Ptr (byteArrayContents# ba)
          , let go k | isTrue# (k >=# nm) = []
                     | otherwise = unsafeFromByteArrayOffset k ba
                                 : go (k +# n)
            in go 0#
          )
        #)
  )
{-# INLINE mallocVkDataArray #-}

-- | Get pointer to vulkan structure.
--   Note, the address is only valid as long as a given vulkan structure exists.
--   Structures created with newVkData are stored in pinned byte arrays,
--   so their memory is maintained by Haskell GC.
unsafePtr  :: IsVkStruct a => a -> Ptr a
unsafePtr a = Ptr (unsafeAddr a)
{-# INLINE unsafePtr #-}

-- | Get vulkan structure referenced by a 'ForeignPtr' trying to avoid copying data.
--
--   This function does copy data if called on an unmanaged `ForeignPtr`
--   (i.e. one created from ordinary `Ptr` using something like `newForeignPtr`.).
--
--   This function does not copy data if called on a managed `ForeignPtr`
--   (i.e. one created using `mallocForeignPtr`, or `toForeignPtr`, or `toPlainForeignPtr`).
--
--   Note, `fromForeignPtr` does not copy finalizers of `ForeignPtr`.
--   Thus, if all references to original `ForeignPtr` are lost,
--     its attached finalizers may run even if the created structure is alive.
fromForeignPtr :: forall a . VulkanMarshal a => ForeignPtr a -> IO a
fromForeignPtr (ForeignPtr addr PlainForeignPtr{})
  | I# n <- sSize @(StructRep a)
  , I# a <- sAlign @(StructRep a)
  = IO
  (\s0 -> case newAlignedPinnedByteArray# n a s0 of
    (# s1, mba #) -> case copyAddrToByteArray# addr mba 0# n s1 of
      s2 -> case unsafeFreezeByteArray# mba s2 of
        (# s3, ba #) -> (# s3, unsafeFromByteArrayOffset 0# ba  #)
  )
fromForeignPtr (ForeignPtr addr (MallocPtr mba _))
  = IO
  (\s0 -> case unsafeFreezeByteArray# mba s0 of
    (# s1, ba #) -> (# s1, unsafeFromByteArrayOffset
                           (minusAddr# addr (byteArrayContents# ba)) ba  #)
  )
fromForeignPtr (ForeignPtr addr (PlainPtr mba))
  = IO
  (\s0 -> case unsafeFreezeByteArray# mba s0 of
    (# s1, ba #) -> (# s1, unsafeFromByteArrayOffset
                           (minusAddr# addr (byteArrayContents# ba)) ba  #)
  )
{-# INLINE fromForeignPtr #-}


-- | Create a `ForeignPtr` referencing the structure without copying data.
toForeignPtr :: IsVkStruct a => a -> IO (ForeignPtr a)
toForeignPtr x
  | a <- unsafeAddr x
  , b <- unsafeByteArray x = do
    ForeignPtr _ (PlainForeignPtr r)
      <- newForeignPtr_ (Ptr a)
    IO (\s -> (# s, ForeignPtr a (MallocPtr (unsafeCoerce# b) r) #))
{-# INLINE toForeignPtr #-}

-- | Create a `ForeignPtr` referencing the structure without copying data.
--   This version of a pointer carries no finalizers.
--
-- It is not possible to add a finalizer to a ForeignPtr created with
-- @toPlainForeignPtr@.
-- Attempts to add a finalizer to a ForeignPtr created this way, or to
-- finalize such a pointer, will throw an exception.
toPlainForeignPtr :: IsVkStruct a => a -> IO (ForeignPtr a)
toPlainForeignPtr (VkStruct a b) = IO
    (\s -> (# s, ForeignPtr a (PlainPtr (unsafeCoerce# b)) #))
{-# INLINE toPlainForeignPtr #-}

-- | Make sure this data is alive at a given point in a sequence of IO actions.
touchVkData  :: IsVkStruct a => a -> IO ()
touchVkData (VkStruct _ b) = IO (\s -> (# touch# b s, () #))
{-# INLINE touchVkData #-}



type StructFieldNames (a :: Type) = FieldNames (StructFields a)

type family FieldNames (ms :: [FieldMeta]) :: [Symbol] where
    FieldNames '[] = '[]
    FieldNames (m ': ms) = FName m ': FieldNames ms

-- | A Constraint: a vulkan struct must have a field with a given name.
type HasField (fname :: Symbol) (a :: Type)
    = (VulkanMarshal a, VulkanField (FieldRep fname a))

-- | Type-level description of a Vulkan structure field.
type FieldRep (fname :: Symbol) (a :: Type)
    = GetFieldMeta (ErrorNoSuchField fname a) fname (StructFields a)

-- | Type of a field in a vulkan structure or union.
type FieldType (fname :: Symbol) (a :: Type)
    = FType (FieldRep fname a)

-- | Whether this field marked optional in vulkan specification.
--   Usually, this means that `VK_NULL` can be written in place
--   of this field.
type FieldOptional (fname :: Symbol) (a :: Type)
    = FOptional (FieldRep fname a)

-- | Offset of a field in bytes.
type FieldOffset (fname :: Symbol) (a :: Type)
    = FByteOffset (FieldRep fname a)

-- | Whether this field is a fixed-length array stored directly in a struct.
type FieldIsArray (fname :: Symbol) (a :: Type)
    = IsArrayLen (FLength (FieldRep fname a))

type family IsArrayLen (l :: Nat) :: Bool where
    IsArrayLen 1 = 'False
    IsArrayLen _ = 'True

-- | Length of an array that is a field of a structure or union
type FieldArrayLength (fname :: Symbol) (a :: Type)
    = FLength (FieldRep fname a)

type CanReadField (fname :: Symbol) (a :: Type)
    = ( HasField fname a
      , IsTrue (ErrorNotReadableField fname a)
               (FCanRead (FieldRep fname a))
      , Storable (FieldType fname a))

type CanWriteField (fname :: Symbol) (a :: Type)
    = ( HasField fname a
      , IsTrue (ErrorNotWritableField fname a)
               (FCanWrite (FieldRep fname a))
      , Storable (FieldType fname a))

type CanReadFieldArray (fname :: Symbol) (a :: Type)
    = CanReadField fname a

type CanWriteFieldArray (fname :: Symbol) (a :: Type)
    = CanWriteField fname a

instance VulkanMarshal (VkStruct a)
       => Eq (VkStruct a) where
    a == b = EQ == cmpBytes# (sizeOf a) (unsafeAddr a) (unsafeAddr b)
    {-# INLINE (==) #-}

instance VulkanMarshal (VkStruct a)
       => Ord (VkStruct a) where
    compare a b = cmpBytes# (sizeOf a) (unsafeAddr a) (unsafeAddr b)
    {-# INLINE compare #-}

instance VulkanMarshal (VkStruct a)
       => Storable (VkStruct a) where
    sizeOf ~_ = sSize @(StructRep (VkStruct a))
    {-# INLINE sizeOf #-}
    alignment ~_ = sAlign @(StructRep (VkStruct a))
    {-# INLINE alignment #-}
    peek (Ptr addr)
      | I# n <- sSize @(StructRep (VkStruct a))
      , I# a <- sAlign @(StructRep (VkStruct a))
      = IO
      (\s -> case newAlignedPinnedByteArray# n a s of
        (# s1, mba #) -> case copyAddrToByteArray# addr mba 0# n s1 of
          s2 -> case unsafeFreezeByteArray# mba s2 of
            (# s3, ba #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
      )
    {-# INLINE peek #-}
    poke (Ptr addr) x
      = c_memcpy addr (unsafeAddr x) (fromIntegral $ sSize @(StructRep (VkStruct a)))
    {-# INLINE poke #-}


instance VulkanMarshal (VkStruct a)
       => Show (VkStruct a) where
    showsPrec d x
      = showParen (d >= 11)
      $ (.) (showString (sName @(StructRep (VkStruct a))) . showString " {")
      $ (\(b, s) -> if b then dropIt . s else s )
      $ enumerateFields @(StructFields (VkStruct a))
        ( \(_ :: Proxy# m) s -> case isThatField @m of
            Refl ->
              ( True
              , sepIt . showString (fName @m)
                . showString " = " . showField @(FName m) @m
                . snd s
              )
        ) (False, showString "}")

      where
        (dropIt, sepIt) = if sIsUnion @(StructRep (VkStruct a))
                          then (drop 3, showString " | ")
                          else (drop 2, showString ", ")
        isThatField :: m :~: FieldRep (FName m) (VkStruct a)
        isThatField = unsafeCoerce (Refl :: m :~: m)
        showField :: forall (fname :: Symbol) (m :: FieldMeta)
                   . ( VulkanField m
                     , fname ~ FName m
                     , m ~ FieldRep fname (VkStruct a)
                     )
                  => ShowS
        showField = case fLength @m of
            0 -> showString "[]"
            1 -> shows @(FType m) (getF 0)
            m -> showChar '[' . drop 2
               . foldr (\i s -> showString ", " . shows @(FType m) (getF i) . s)
                       id [0..m-1]
               . showChar ']'
          where
            getF :: Int -> FType m
            getF i = unsafeDupablePerformIO $
              peekByteOff @(FType m) (unsafePtr x)
                (fByteOffset @m + i * sizeOf @(FType m) undefined)
            {-# NOINLINE getF #-}



-- | Whether this field marked optional in vulkan specification.
--   Usually, this means that `VK_NULL` can be written in place
--   of this field.
fieldOptional :: forall (fname :: Symbol) (a :: Type)
               . HasField fname a => Bool
fieldOptional = fOptional @(FieldRep fname a)

-- | Offset of a field in bytes.
fieldOffset :: forall (fname :: Symbol) (a :: Type)
             . HasField fname a => Int
fieldOffset = fByteOffset @(FieldRep fname a)

-- | Length of an array that is a field of a structure or union.
--
--   Returns @1@ if this field is not an array.
fieldArrayLength :: forall (fname :: Symbol) (a :: Type)
                  . HasField fname a => Int
fieldArrayLength = fLength @(FieldRep fname a)

getField :: forall (fname :: Symbol) (a :: Type)
          . CanReadField fname a => a -> FieldType fname a
getField x = unsafeDupablePerformIO $
    peekByteOff (unsafePtr x) (fieldOffset @fname @a)
{-# NOINLINE getField #-}

readField :: forall (fname :: Symbol) (a :: Type)
           . CanReadField fname a => Ptr a -> IO (FieldType fname a)
readField p = peekByteOff p (fieldOffset @fname @a)

writeField :: forall (fname :: Symbol) (a :: Type)
            . CanWriteField fname a => Ptr a -> FieldType fname a -> IO ()
writeField p = pokeByteOff p (fieldOffset @fname @a)

-- | Index an array-type field. No bound checks.
getFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
                     . CanReadFieldArray fname a => Int -> a -> FieldType fname a
getFieldArrayUnsafe i = f
  where
    off = fieldOffset @fname @a + i * sizeOf @(FieldType fname a) undefined
    f x = unsafeDupablePerformIO (peekByteOff (unsafePtr x) off)
    {-# NOINLINE f #-}

-- | Read from an array-type field. No bound checks.
readFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
                      . CanReadFieldArray fname a => Int -> Ptr a -> IO (FieldType fname a)
readFieldArrayUnsafe i p = peekByteOff p off
  where
    off = fieldOffset @fname @a + i * sizeOf @(FieldType fname a) undefined

-- | Write to an array-type field. No bound checks.
writeFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
                       . CanWriteFieldArray fname a
                      => Int -> Ptr a -> FieldType fname a -> IO ()
writeFieldArrayUnsafe i p = pokeByteOff p off
  where
    off = fieldOffset @fname @a + i * sizeOf @(FieldType fname a) undefined


getFieldArray :: forall fname idx a
               . (CanReadFieldArray fname a, IndexInBounds fname idx a, KnownNat idx)
              => a -> FieldType fname a
getFieldArray = getFieldArrayUnsafe @fname @a
  (fromInteger $ natVal' (proxy# :: Proxy# idx))
{-# INLINE getFieldArray #-}

readFieldArray :: forall fname idx a
                . (CanReadFieldArray fname a, IndexInBounds fname idx a, KnownNat idx)
               => Ptr a -> IO (FieldType fname a)
readFieldArray = readFieldArrayUnsafe @fname @a
  (fromInteger $ natVal' (proxy# :: Proxy# idx))
{-# INLINE readFieldArray #-}


writeFieldArray :: forall fname idx a
                 . (CanWriteFieldArray fname a, IndexInBounds fname idx a, KnownNat idx)
                => Ptr a -> FieldType fname a -> IO ()
writeFieldArray = writeFieldArrayUnsafe @fname @a
  (fromInteger $ natVal' (proxy# :: Proxy# idx))
{-# INLINE writeFieldArray #-}



type IndexInBounds (s :: Symbol) (i :: Nat) (a :: Type)
  = IndexInBounds' s i a (CmpNat i (FieldArrayLength s a))

type family IndexInBounds' (s :: Symbol)
                           (i :: Nat)
                           (a :: Type) (r :: Ordering) :: Constraint where
  IndexInBounds' _ _ _ 'LT = ()
  IndexInBounds' s i a _ = TypeError ( ErrorIndexOutOfBounds s i a )


--------------------------------------------------------------------------------
-- * Type-level errors
--------------------------------------------------------------------------------

type family IsTrue (errMsg :: ErrorMessage) (bool :: Bool) :: Constraint where
  IsTrue _   'True  = ()
  IsTrue err 'False = TypeError err

type ErrorNoSuchField (s :: Symbol) (a :: Type)
  = 'Text "Structure " ':<>: 'ShowType a
  ':<>: 'Text " does not have field " ':<>: 'ShowType s ':<>: 'Text "."
  ':$$: 'Text "Note, this structure has following fields: "
        ':<>: 'ShowType (StructFieldNames a)

type ErrorIndexOutOfBounds (s :: Symbol) (i :: Nat) (a :: Type)
  = 'Text "Array index " ':<>: 'ShowType i ':<>:
    'Text " is out of bounds for '" ':<>:
    'Text s ':<>: 'Text "',  member of type " ':<>: 'ShowType a ':<>: 'Text "."
  ':$$:
    'Text "Note: the array size is "
      ':<>: 'ShowType (FieldArrayLength s a) ':<>: 'Text "."

type ErrorNotReadableField (s :: Symbol) (a :: Type)
  = 'Text "Field " ':<>: 'ShowType s ':<>:
    'Text " of structure " ':<>: 'ShowType a ':<>:
    'Text " is not readable."

type ErrorNotWritableField (s :: Symbol) (a :: Type)
  = 'Text "Field " ':<>: 'ShowType s ':<>:
    'Text " of structure " ':<>: 'ShowType a ':<>:
    'Text " is not writable."


--------------------------------------------------------------------------------
-- * Utilities for CString
--------------------------------------------------------------------------------

-- | Perform an action on a C string field.
--   The string pointers should not be used outside the callback.
--   It will point to a correct location only as long as the struct is alive.
withCStringField :: forall fname a b
                 . ( CanReadFieldArray fname a
                   , FieldType fname a ~ CChar
                   , VulkanMarshal a
                   )
                 => a -> (CString -> IO b) -> IO b
withCStringField x f = do
  r <- f (unsafeCStringField @fname @a x)
  touchVkData x
  pure r

-- | Get pointer to a memory location of the C string field in a structure.
unsafeCStringField :: forall fname a
                   . ( CanReadFieldArray fname a
                     , FieldType fname a ~ CChar
                     , VulkanMarshal a
                     )
                   => a -> CString
unsafeCStringField x = unsafePtr x `plusPtr` fieldOffset @fname @a


getStringField :: forall fname a
                . ( CanReadFieldArray fname a
                  , FieldType fname a ~ CChar
                  , VulkanMarshal a
                  )
               => a -> String
getStringField x
    = case takeForce (fieldArrayLength @fname @a)
         . unsafeDupablePerformIO
         $ withCStringField @fname @a x peekCString of
        ((), s) -> s

readStringField :: forall fname a
                . ( CanReadFieldArray fname a
                  , FieldType fname a ~ CChar
                  , VulkanMarshal a
                  )
               => Ptr a -> IO String
readStringField px = do
  ((), s) <- takeForce (fieldArrayLength @fname @a)
         <$> peekCString (px `plusPtr` fieldOffset @fname @a)
  return s

writeStringField :: forall fname a
                  . ( CanWriteFieldArray fname a
                    , FieldType fname a ~ CChar
                    , VulkanMarshal a
                    )
               => Ptr a -> String -> IO ()
writeStringField px =
  pokeArray0 '\0' (px `plusPtr` fieldOffset @fname @a)

takeForce :: Int -> String -> ((), String)
takeForce 0 _      = ((), [])
takeForce _ []     = ((), [])
takeForce n (x:xs) = seq x $ (x:) <$> takeForce (n-1) xs


-- | Check first if two CString point to the same memory location.
--   Otherwise, compare them using C @strcmp@ function.
cmpCStrings :: CString -> CString -> Ordering
cmpCStrings a b
  | a == b = EQ
  | otherwise = c_strcmp a b `compare` 0

-- | Check first if two CString point to the same memory location.
--   Otherwise, compare them using C @strncmp@ function.
--   It may be useful to provide maximum number of characters to compare.
cmpCStringsN :: CString -> CString -> Int -> Ordering
cmpCStringsN a b n
  | a == b = EQ
  | otherwise = c_strncmp a b (fromIntegral n) `compare` 0

foreign import ccall unsafe "strncmp"
  c_strncmp :: CString -> CString -> CSize -> CInt

foreign import ccall unsafe "strcmp"
  c_strcmp :: CString -> CString -> CInt

-- | Internal function used to implement Eq and Ord instances for Vulkan structs.
--   Compares first n bytes of two memory areas.
--
--   Uses lexicographic ordering (c memcmp inside).
--
--   This is a helper that should be used in VulkanMarshal instances only.
cmpBytes# :: Int -> Addr# -> Addr# -> Ordering
cmpBytes# n a b
  | isTrue# (eqAddr# a b) = EQ
  | otherwise = c_memcmp a b (fromIntegral n) `compare` 0


foreign import ccall unsafe "memcmp"
  c_memcmp :: Addr# -> Addr# -> CSize -> CInt


foreign import ccall unsafe "memcpy"
  c_memcpy :: Addr# -> Addr# -> CSize -> IO ()