{-|
Module      : Foreign.Storable.Generic.Internal
Copyright   : (c) Mateusz Kłoczko, 2016
License     : MIT
Maintainer  : mateusz.p.kloczko@gmail.com
Stability   : experimental
Portability : portable


-}

{-#LANGUAGE FlexibleInstances    #-}
{-#LANGUAGE FlexibleContexts     #-}
{-#LANGUAGE DefaultSignatures    #-}
{-#LANGUAGE TypeOperators        #-}
{-#LANGUAGE ScopedTypeVariables  #-}
{-#LANGUAGE UndecidableInstances #-}
{-#LANGUAGE DataKinds            #-}

{-#LANGUAGE TypeFamilies         #-}
{-#LANGUAGE MultiParamTypeClasses#-}
{-#LANGUAGE ConstraintKinds      #-}
{-#LANGUAGE CPP                  #-}

module Foreign.Storable.Generic.Internal (
     GStorable'(..),
     GStorable (..),
     Storable (..),
#ifdef GSTORABLE_SUMTYPES
     GStorableSum'(..),
     GStorableChoice'(..),
     GStorableChoice,
     internalTagValue,
#endif
     internalSizeOf,
     internalAlignment,
     internalPeekByteOff,
     internalPokeByteOff,
     internalOffsets
  ) where

import GHC.TypeLits
import GHC.Generics
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.C.Types

import Data.Proxy
import Data.Word
import Data.Int

import Debug.Trace

import Foreign.Storable.Generic.Tools
import Foreign.Storable.Generic.Tools.TypeFuns

import GHC.Exts

-- Defining the generics ---

class GStorable' f where
    -- | Read the element at a given offset. Additional information about the offests 
    -- of the subfields are needed.
    gpeekByteOff' :: [Int]    -- ^ List of fields' offsets for the type/struct. 
                  -> Int      -- ^ The index. Used to obtain the correct offset
                  -> Ptr b    -- ^ The pointer to the type/struct.
                  -> Int      -- ^ Global offset.
                  -> IO (f a) -- ^ The result, wrapped in GHC.Generic metadata.
    -- | Write the element at a given offset. Additional information about the offests 
    -- of the subfields are needed.
    gpokeByteOff' :: [Int]  -- ^ List of fields' offsets for the type/struct.
                  -> Int    -- ^ The index. Used to obtain the correct offset.
                  -> Ptr b  -- ^ The pointer to the type/struct.
                  -> Int    -- ^ Global offset.
                  -> (f a)  -- ^ The element to write, wrapped in GHC.Generic metadata.
                  -> IO ()

    -- | Calculates the sizes of type's/struct's fields.
    glistSizeOf' :: f a    -- ^ GHC.Generic information about a given type/struct. 
                 -> [Size] -- ^ List of sizes.

    -- | Calculates the alignments of type's/struct's fields.
    glistAlignment' :: f a         -- ^ GHC.Generic information about a given type/struct.
                    -> [Alignment] -- ^ List of alignments.


instance (GStorable' f) => GStorable' (M1 i t f) where
    -- Wrap the peeked value in metadata.
    {-# INLINE gpeekByteOff' #-}
    gpeekByteOff' :: [Int] -> Int -> Ptr b -> Int -> IO (M1 i t f a)
gpeekByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset = f a -> M1 i t f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 i t f a) -> IO (f a) -> IO (M1 i t f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Int -> Ptr b -> Int -> IO (f a)
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> IO (f a)
gpeekByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset
    -- Discard the metadata and go further.
    {-# INLINE gpokeByteOff' #-}
    gpokeByteOff' :: [Int] -> Int -> Ptr b -> Int -> M1 i t f a -> IO ()
gpokeByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset (M1 f a
x) = [Int] -> Int -> Ptr b -> Int -> f a -> IO ()
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> f a -> IO ()
gpokeByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset f a
x 
    
    glistSizeOf' :: M1 i t f a -> [Int]
glistSizeOf' M1 i t f a
_ = f Any -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistSizeOf' (forall p. f p
forall a. HasCallStack => a
undefined :: f p)
    glistAlignment' :: M1 i t f a -> [Int]
glistAlignment' M1 i t f a
_ = f Any -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistAlignment' (forall p. f p
forall a. HasCallStack => a
undefined :: f p)

instance GStorable' U1 where
    -- Wrap the peeked value in metadata.
    {-# INLINE gpeekByteOff' #-}
    gpeekByteOff' :: [Int] -> Int -> Ptr b -> Int -> IO (U1 a)
gpeekByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset = U1 a -> IO (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1
    -- Discard the metadata and go further.
    {-# INLINE gpokeByteOff' #-}
    gpokeByteOff' :: [Int] -> Int -> Ptr b -> Int -> U1 a -> IO ()
gpokeByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset (U1 a
U1) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    
    glistSizeOf' :: U1 a -> [Int]
glistSizeOf'    U1 a
_ = []
    glistAlignment' :: U1 a -> [Int]
glistAlignment' U1 a
_ = []

instance (KnownNat (NoFields f), KnownNat (NoFields g)
         , GStorable' f, GStorable' g) => GStorable' (f :*: g) where
    -- Tree-like traversal for reading the type.
    {-# INLINE gpeekByteOff' #-}
    gpeekByteOff' :: [Int] -> Int -> Ptr b -> Int -> IO ((:*:) f g a)
gpeekByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset = f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a) -> IO (f a) -> IO (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (f a)
peeker1 Int
new_ix IO (g a -> (:*:) f g a) -> IO (g a) -> IO ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>  Int -> IO (g a)
peeker2 Int
ix
        where new_ix :: Int
new_ix =  Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n2                                        -- The new index for the left part of the tree.
              n2 :: Int
n2 = g Any -> Int
forall (f :: * -> *) p. KnownNat (NoFields f) => f p -> Int
noFields (forall a. g a
forall a. HasCallStack => a
undefined :: g a)                       -- Number of elements for the right part of the tree
              peeker1 :: Int -> IO (f a)
peeker1 Int
n_ix = [Int] -> Int -> Ptr b -> Int -> IO (f a)
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> IO (f a)
gpeekByteOff' [Int]
offsets Int
n_ix Ptr b
ptr Int
offset      -- gpeekByteOff' wrapped to peek into subtrees.
              peeker2 :: Int -> IO (g a)
peeker2 Int
n_ix = [Int] -> Int -> Ptr b -> Int -> IO (g a)
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> IO (f a)
gpeekByteOff' [Int]
offsets Int
n_ix Ptr b
ptr Int
offset      -- gpeekByteOff' wrapped to peek into subtrees.
    -- Tree like traversal for writing the type.
    {-# INLINE gpokeByteOff' #-}
    gpokeByteOff' :: [Int] -> Int -> Ptr b -> Int -> (:*:) f g a -> IO ()
gpokeByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset (f a
x :*: g a
y) = Int -> f a -> IO ()
peeker1 Int
new_ix f a
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> g a -> IO ()
peeker2 Int
ix g a
y
        where new_ix :: Int
new_ix = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n2                                 
              n2 :: Int
n2 = g Any -> Int
forall (f :: * -> *) p. KnownNat (NoFields f) => f p -> Int
noFields (forall a. g a
forall a. HasCallStack => a
undefined :: g a)               -- Number of elements for the right part of the tree.
              peeker1 :: Int -> f a -> IO ()
peeker1 Int
n_ix f a
z = [Int] -> Int -> Ptr b -> Int -> f a -> IO ()
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> f a -> IO ()
gpokeByteOff' [Int]
offsets Int
n_ix Ptr b
ptr Int
offset f a
z  -- gpokeByteOff' wrapped to peek into the subtree
              peeker2 :: Int -> g a -> IO ()
peeker2 Int
n_ix g a
z = [Int] -> Int -> Ptr b -> Int -> g a -> IO ()
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> f a -> IO ()
gpokeByteOff' [Int]
offsets Int
n_ix Ptr b
ptr Int
offset g a
z  -- gpokeByteOff' wrapped to peek into the subtree



    -- Concatenate the lists. 
    glistSizeOf' :: (:*:) f g a -> [Int]
glistSizeOf' (:*:) f g a
_ = f Any -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistSizeOf' (forall a. f a
forall a. HasCallStack => a
undefined :: f a) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ g Any -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistSizeOf' (forall a. g a
forall a. HasCallStack => a
undefined :: g a)
    -- Concatenate the lists.
    glistAlignment' :: (:*:) f g a -> [Int]
glistAlignment' (:*:) f g a
_ = f Any -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistAlignment' (forall a. f a
forall a. HasCallStack => a
undefined :: f a) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ g Any -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistAlignment' (forall a. g a
forall a. HasCallStack => a
undefined :: g a)

instance (Storable a) => GStorable' (K1 i a) where
    {-# INLINE gpeekByteOff' #-}
    gpeekByteOff' :: [Int] -> Int -> Ptr b -> Int -> IO (K1 i a a)
gpeekByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> IO a -> IO (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr b -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr (Int
off1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
        where off1 :: Int
off1 = Int -> Int
forall a. a -> a
inline ([Int]
offsets [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
ix)
    {-# INLINE gpokeByteOff' #-}
    gpokeByteOff' :: [Int] -> Int -> Ptr b -> Int -> K1 i a a -> IO ()
gpokeByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
offset (K1 a
x) = Ptr b -> Int -> a -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptr (Int
off1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset) a
x
        where off1 :: Int
off1 = Int -> Int
forall a. a -> a
inline ([Int]
offsets [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
ix) 


    -- When the constructor is used, return the size of 
    -- the constructed type in a list.
    glistSizeOf' :: K1 i a a -> [Int]
glistSizeOf' K1 i a a
_ = [a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)]
    -- When the constructor is used, return the alignment of 
    -- the constructed type in a list.
    glistAlignment' :: K1 i a a -> [Int]
glistAlignment' K1 i a a
_ = [a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)]  

#ifndef GSTORABLE_SUMTYPES
type SumTypesDisabled = Text "By default sum types are not supported by GStorable instances." :$$: Text "You can pass a 'sumtypes' flag through 'cabal new-configure' to enable them." :$$: Text "In case of trouble, one can use '-DGSTORABLE_SUMTYPES' ghc flag instead." 

instance (TypeError SumTypesDisabled) => GStorable' (f :+: g) where
    gpeekByteOff' :: [Int] -> Int -> Ptr b -> Int -> IO ((:+:) f g a)
gpeekByteOff'   = [Int] -> Int -> Ptr b -> Int -> IO ((:+:) f g a)
forall a. HasCallStack => a
undefined
    gpokeByteOff' :: [Int] -> Int -> Ptr b -> Int -> (:+:) f g a -> IO ()
gpokeByteOff'   = [Int] -> Int -> Ptr b -> Int -> (:+:) f g a -> IO ()
forall a. HasCallStack => a
undefined
    glistSizeOf' :: (:+:) f g a -> [Int]
glistSizeOf'    = (:+:) f g a -> [Int]
forall a. HasCallStack => a
undefined
    glistAlignment' :: (:+:) f g a -> [Int]
glistAlignment' = (:+:) f g a -> [Int]
forall a. HasCallStack => a
undefined
#endif

-- These functions were moved outside GStorable type class.
-- They take generic representations as input.

{-# INLINE internalSizeOf #-}
-- | Calculates the size of generic data-type.
internalSizeOf :: forall f p. (GStorable' f)
               => f p  -- ^ Generic representation 
               -> Int  -- ^ Resulting size
internalSizeOf :: f p -> Int
internalSizeOf f p
_  = [(Int, Int)] -> Int
calcSize ([(Int, Int)] -> Int) -> [(Int, Int)] -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
sizes [Int]
aligns
    where sizes :: [Int]
sizes  = f p -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistSizeOf'    (f p
forall a. HasCallStack => a
undefined :: f p)
          aligns :: [Int]
aligns = f p -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistAlignment' (f p
forall a. HasCallStack => a
undefined :: f p)

{-# INLINE internalAlignment #-}
-- | Calculates the alignment of generic data-type.
internalAlignment :: forall f p. (GStorable' f) 
                  => f p       -- ^ Generic representation
                  -> Alignment -- ^ Resulting alignment
internalAlignment :: f p -> Int
internalAlignment  f p
_  = [Int] -> Int
calcAlignment [Int]
aligns
    where aligns :: [Int]
aligns = f p -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistAlignment' (f p
forall a. HasCallStack => a
undefined :: f p)

{-# INLINE internalPeekByteOff #-}
-- | View the variable under a pointer, with offset.
internalPeekByteOff :: forall f p b. (KnownNat (NoFields f), GStorable' f) 
                    => Ptr b    -- ^ Pointer to peek 
                    -> Offset   -- ^ Offset 
                    -> IO (f p) -- ^ Resulting generic representation
internalPeekByteOff :: Ptr b -> Int -> IO (f p)
internalPeekByteOff Ptr b
ptr Int
off  = [Int] -> Int -> Ptr b -> Int -> IO (f p)
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> IO (f a)
gpeekByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
off
    where offsets :: [Int]
offsets = f p -> [Int]
forall (f :: * -> *) p. GStorable' f => f p -> [Int]
internalOffsets (f p
forall a. HasCallStack => a
undefined :: f p)
          ix :: Int
ix      = f p -> Int
forall (f :: * -> *) p. KnownNat (NoFields f) => f p -> Int
noFields (f p
forall a. HasCallStack => a
undefined :: f p) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

{-# INLINE internalPokeByteOff #-}
-- | Write the variable under the pointer, with offset.
internalPokeByteOff :: forall f p b. (KnownNat (NoFields f), GStorable' f) 
                    => Ptr b  -- ^ Pointer to write to
                    -> Offset -- ^ Offset 
                    -> f p    -- ^ Written generic representation 
                    -> IO () 
internalPokeByteOff :: Ptr b -> Int -> f p -> IO ()
internalPokeByteOff Ptr b
ptr Int
off f p
rep = [Int] -> Int -> Ptr b -> Int -> f p -> IO ()
forall (f :: * -> *) b a.
GStorable' f =>
[Int] -> Int -> Ptr b -> Int -> f a -> IO ()
gpokeByteOff' [Int]
offsets Int
ix Ptr b
ptr Int
off f p
rep
    where offsets :: [Int]
offsets = f p -> [Int]
forall (f :: * -> *) p. GStorable' f => f p -> [Int]
internalOffsets (f p
forall a. HasCallStack => a
undefined :: f p)
          ix :: Int
ix      = f p -> Int
forall (f :: * -> *) p. KnownNat (NoFields f) => f p -> Int
noFields (f p
forall a. HasCallStack => a
undefined :: f p) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

{-# INLINE internalOffsets #-}
-- | Obtain the list of offsets
internalOffsets :: forall f p. (GStorable' f)
                => f p      -- Generic representation
                -> [Offset] -- List of offsets
internalOffsets :: f p -> [Int]
internalOffsets f p
_ = [(Int, Int)] -> [Int]
calcOffsets ([(Int, Int)] -> [Int]) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
sizes [Int]
aligns
    where sizes :: [Int]
sizes = f p -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistSizeOf'    (f p
forall a. HasCallStack => a
undefined :: f p)
          aligns :: [Int]
aligns= f p -> [Int]
forall (f :: * -> *) a. GStorable' f => f a -> [Int]
glistAlignment' (f p
forall a. HasCallStack => a
undefined :: f p)

-- | The class uses the default Generic based implementations to 
-- provide Storable instances for types made from primitive types.
-- Sum types work with 'sumtypes' cabal flag enabled - or 
-- just with -DGSTORABLE_SUMTYPES cpp flag.
class GStorable a where
    {-# INLINE gsizeOf      #-}
    {-# INLINE galignment   #-}
    {-# INLINE gpeekByteOff #-}
    {-# INLINE gpokeByteOff #-}
    -- | Calculate the size of the type.
    gsizeOf :: a   -- ^ Element of a given type. Can be undefined.
            -> Int -- ^ Size.
    
    -- | Calculate the alignment of the type.
    galignment :: a   -- ^ Element of a given type. Can be undefined  
               -> Int -- ^ Alignment.
    
    -- | Read the variable from a given pointer.
    gpeekByteOff :: Ptr b -- ^ Pointer to the variable
                 -> Int   -- ^ Offset
                 -> IO a  -- ^ Returned variable.
    
    -- | Write the variable to a pointer. 
    gpokeByteOff :: Ptr b -- ^ Pointer to the variable. 
                 -> Int   -- ^ Offset.
                 -> a     -- ^ The variable
                 -> IO ()

#ifdef GSTORABLE_SUMTYPES
    default gsizeOf :: (ConstraintsSize a, GStorableChoice a)
                    => a -> Int
    -- gsizeOf _ = chSizeOf @(IsSumType (Rep a)) (undefined :: a)
    gsizeOf = chSizeOf (Proxy :: Proxy (IsSumType (Rep a)))
    
    default galignment :: (ConstraintsAlignment a, GStorableChoice a)
                         => a -> Int
    galignment = chAlignment (Proxy :: Proxy (IsSumType (Rep a)))

    default gpeekByteOff :: (GStorableChoice a, ConstraintsPeek a)
                         => Ptr b -> Int -> IO a
    gpeekByteOff = chPeekByteOff (Proxy :: Proxy (IsSumType (Rep a)))

    default gpokeByteOff :: (GStorableChoice a, ConstraintsPoke a)
                         => Ptr b -> Int -> a -> IO ()
    gpokeByteOff = chPokeByteOff (Proxy :: Proxy (IsSumType (Rep a)))

#else
    default gsizeOf :: (Generic a, GStorable' (Rep a))
                    => a -> Int
    gsizeOf a
_ = Rep a Any -> Int
forall (f :: * -> *) p. GStorable' f => f p -> Int
internalSizeOf (forall p. Rep a p
forall a. HasCallStack => a
undefined :: Rep a p) 
    default galignment :: (Generic a, GStorable' (Rep a))
                         => a -> Int
    galignment a
_ = Rep a Any -> Int
forall (f :: * -> *) p. GStorable' f => f p -> Int
internalAlignment (forall p. Rep a p
forall a. HasCallStack => a
undefined :: Rep a p) 
    default gpeekByteOff :: ( KnownNat (NoFields (Rep a))
                            , Generic a, GStorable' (Rep a))
                         => Ptr b -> Int -> IO a
    gpeekByteOff Ptr b
ptr Int
offset = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> IO (Rep a Any) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr b -> Int -> IO (Rep a Any)
forall (f :: * -> *) p b.
(KnownNat (NoFields f), GStorable' f) =>
Ptr b -> Int -> IO (f p)
internalPeekByteOff Ptr b
ptr Int
offset
    default gpokeByteOff :: ( KnownNat (NoFields (Rep a))
                            , Generic a, GStorable' (Rep a))
                         => Ptr b -> Int -> a -> IO ()
    gpokeByteOff Ptr b
ptr Int
offset a
x = Ptr b -> Int -> Rep a Any -> IO ()
forall (f :: * -> *) p b.
(KnownNat (NoFields f), GStorable' f) =>
Ptr b -> Int -> f p -> IO ()
internalPokeByteOff Ptr b
ptr Int
offset (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
x)
#endif


#ifdef GSTORABLE_SUMTYPES
type GStorableChoice a = GStorableChoice' (IsSumType (Rep a)) a

-- | Choose a GStorable implementation - whether a sum type (with tag) or
-- raw product type (without the tag).
class GStorableChoice' (choice :: Bool) a where
    chSizeOf      :: proxy choice -> a     -> Int
    chAlignment   :: proxy choice -> a     -> Int
    chPeekByteOff :: proxy choice -> Ptr b -> Int -> IO a
    chPokeByteOff :: proxy choice -> Ptr b -> Int ->    a -> IO ()

-- | Implementation for the sum types.
instance ( Generic a, KnownNat (SumArity (Rep a))
         , GStorableSum' (Rep a), IsSumType (Rep a) ~ True) => GStorableChoice' True a where
    {-# INLINE chSizeOf #-}
    {-# INLINE chPeekByteOff #-}
    {-# INLINE chPokeByteOff #-}
    {-# INLINE chAlignment #-}
    chSizeOf _  _ = calcSize $ zip sizes aligns
        where sizes  = (word8s:gsizeOfSum' (undefined :: Rep a p):[])
              aligns = (word8a:alignOfSum' (undefined :: Rep a p):[])
              word8s = sizeOf    (undefined :: Word8)
              word8a = alignment (undefined :: Word8) 
    chAlignment _ _  = calcAlignment $ (word8a:align:[])
        where align  = alignOfSum' (undefined :: Rep a p)
              word8a = alignment   (undefined :: Word8)
    chPeekByteOff _ ptr off = do
        let proxy = (Proxy :: Proxy True)
        choice <- peekByteOff ptr off :: IO Word8
        to <$> gpeekByteOffSum' (fromIntegral choice) ptr (off + chAlignment proxy (undefined :: a))
    chPokeByteOff _ ptr off v = do
        let proxy = (Proxy :: Proxy True)
        pokeByteOff ptr off (internalTagValue v - 1)
        gpokeByteOffSum' ptr (off + chAlignment proxy v) (from v)

-- | Implementation for the non-sum types. 
instance (ConstraintsAll a, IsSumType (Rep a) ~ False) => GStorableChoice' False a where
    {-# INLINE chSizeOf #-}
    {-# INLINE chPeekByteOff #-}
    {-# INLINE chPokeByteOff #-}
    {-# INLINE chAlignment #-}
    chSizeOf    _ _ = internalSizeOf    (undefined :: Rep a p)
    chAlignment _ _ = internalAlignment (undefined :: Rep a p)
    chPeekByteOff _ ptr offset = to <$> internalPeekByteOff ptr offset
    chPokeByteOff _ ptr offset x = internalPokeByteOff ptr offset (from x)


type ConstraintsAll       a = (ConstraintsSize a, ConstraintsPeek a)
type ConstraintsAlignment a = ConstraintsSA' (IsSumType (Rep a)) a 
type ConstraintsSize      a = ConstraintsSA' (IsSumType (Rep a)) a 
type ConstraintsPeek      a = ConstraintsP'  (IsSumType (Rep a)) a
type ConstraintsPoke      a = ConstraintsP'  (IsSumType (Rep a)) a

-- | Constrains for sizeof and alignment, either for sum or non-sum types.
type family ConstraintsSA' (t :: Bool) a where
    ConstraintsSA' True  a = (Generic a, GStorableSum' (Rep a))
    ConstraintsSA' False a = (Generic a, GStorable'    (Rep a))

-- | Constrains for peek and poke operations, either for sum or non-sum types.
type family ConstraintsP' (t :: Bool) a where
    ConstraintsP' True   a = ( Generic a, GStorableSum' (Rep a))
    ConstraintsP' False  a = ( KnownNat (NoFields (Rep a)), Generic a, GStorable' (Rep a))

-- | Get the tag value from the generic representation.
internalTagValue :: ( KnownNat (SumArity (Rep a))
                    , GStorableSum' (Rep a), Generic a)
                 => a -> Word8
internalTagValue (a :: a) = seeFirstByte' (from a) (sumArity (undefined :: Rep a p))

-- | Work on the sum type.
class GStorableSum' f where
    seeFirstByte'    :: f p -> Int -> Word8
    -- | The size of the biggest subtree
    gsizeOfSum'      :: f p -> Int
    -- | Alignment of the biggest subtree
    alignOfSum'      :: f p -> Int
    -- | Peek the type based on the tag.
    gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO (f p)
    gpokeByteOffSum' ::        Ptr b -> Int -> f p -> IO ()

instance (GStorableSum' f) => GStorableSum' (M1 D t f) where
    {-# INLINE seeFirstByte'      #-}
    {-# INLINE gsizeOfSum'        #-}
    {-# INLINE alignOfSum'        #-}
    {-# INLINE gpeekByteOffSum'   #-}
    {-# INLINE gpokeByteOffSum'   #-}
    seeFirstByte'    (M1 v) acc = seeFirstByte' v acc
    gsizeOfSum'      (M1 v)     = gsizeOfSum' v
    alignOfSum'      (M1 v)     = alignOfSum' v
    gpeekByteOffSum' ch ptr off        = M1 <$> gpeekByteOffSum' ch ptr off
    gpokeByteOffSum'    ptr off (M1 v) =        gpokeByteOffSum'    ptr off v

instance (KnownNat (NoFields f), GStorable' f, GStorableSum' f) => GStorableSum' (M1 C t f) where
    {-# INLINE seeFirstByte'      #-}
    {-# INLINE gsizeOfSum'        #-}
    {-# INLINE alignOfSum'        #-}
    {-# INLINE gpeekByteOffSum'   #-}
    {-# INLINE gpokeByteOffSum'   #-}
    seeFirstByte' (M1 v) acc = fromIntegral acc
    gsizeOfSum'   (M1 v)     = internalSizeOf    v
    alignOfSum'   (M1 v)     = internalAlignment v
    gpeekByteOffSum' _ ptr off   = M1 <$> internalPeekByteOff ptr off
    gpokeByteOffSum'   ptr off v = internalPokeByteOff ptr off v

instance ( KnownNat (SumArity g), KnownNat (SumArity f)
         , GStorableSum' f, GStorableSum' g) => GStorableSum' (f :+: g) where
    {-# INLINE seeFirstByte'      #-}
    {-# INLINE gsizeOfSum'        #-}
    {-# INLINE alignOfSum'        #-}
    {-# INLINE gpeekByteOffSum'   #-}
    {-# INLINE gpokeByteOffSum'   #-}
    seeFirstByte' (L1 l) acc = seeFirstByte' l $ acc - (sumArity (undefined :: g p))
    seeFirstByte' (R1 r) acc = seeFirstByte' r   acc
    gsizeOfSum'   _ = max (gsizeOfSum' (undefined :: f p)) (gsizeOfSum' (undefined :: g p))
    alignOfSum'   _ = max (alignOfSum' (undefined :: f p)) (alignOfSum' (undefined :: g p))
    gpeekByteOffSum' choice ptr off = if arityL > choice
            then L1 <$> gpeekByteOffSum'  choice           ptr off
            else R1 <$> gpeekByteOffSum' (choice - arityL) ptr off
        where arityL = sumArity (undefined :: f p) 
    gpokeByteOffSum'        ptr off (R1 v) = gpokeByteOffSum' ptr off v
    gpokeByteOffSum'        ptr off (L1 v) = gpokeByteOffSum' ptr off v

instance (GStorableSum' f) => GStorableSum' (M1 S t f) where
    seeFirstByte'    _   _ = error "Shouldn't be here"
    gsizeOfSum'      _     = error "Shouldn't be here"
    alignOfSum'      _     = error "Shouldn't be here"
    gpeekByteOffSum' _ _ _ = error "Shouldn't be here"
    gpokeByteOffSum' _ _ _ = error "Shouldn't be here"


instance GStorableSum' (f :*: g) where
    seeFirstByte' (l :*: g) acc = undefined
    gsizeOfSum'   _ = undefined
    alignOfSum'   _ = undefined
    gpeekByteOffSum' _ _ _ = undefined
    gpokeByteOffSum' _ _ _ = undefined

instance GStorableSum' (K1 i a) where
    seeFirstByte' _ acc = undefined
    gsizeOfSum'   _ = undefined
    alignOfSum'   _ = undefined
    gpeekByteOffSum' _ _ _ = undefined
    gpokeByteOffSum' _ _ _ = undefined

instance GStorableSum' (U1) where
    seeFirstByte' _ _ = undefined
    gsizeOfSum'   _   = undefined
    alignOfSum'   _   = undefined
    gpeekByteOffSum' _ _ _ = undefined
    gpokeByteOffSum' _ _ _ = undefined

instance GStorableSum' (V1) where
    seeFirstByte' _ _ = undefined
    gsizeOfSum'   _   = undefined
    alignOfSum'   _   = undefined
    gpeekByteOffSum' _ _ _ = undefined
    gpokeByteOffSum' _ _ _ = undefined
#endif

------Association to Storable class-------

instance {-# OVERLAPS #-} (GStorable a) => (Storable a) where
    {-# INLINE sizeOf #-}
    sizeOf :: a -> Int
sizeOf      = a -> Int
forall a. GStorable a => a -> Int
gsizeOf
    {-# INLINE alignment #-}
    alignment :: a -> Int
alignment   = a -> Int
forall a. GStorable a => a -> Int
galignment
    {-# INLINE peekByteOff #-}
    peekByteOff :: Ptr b -> Int -> IO a
peekByteOff = Ptr b -> Int -> IO a
forall a b. GStorable a => Ptr b -> Int -> IO a
gpeekByteOff
    {-# INLINE pokeByteOff #-}
    pokeByteOff :: Ptr b -> Int -> a -> IO ()
pokeByteOff = Ptr b -> Int -> a -> IO ()
forall a b. GStorable a => Ptr b -> Int -> a -> IO ()
gpokeByteOff