{-#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
class GStorable' f where
gpeekByteOff' :: [Int]
-> Int
-> Ptr b
-> Int
-> IO (f a)
gpokeByteOff' :: [Int]
-> Int
-> Ptr b
-> Int
-> (f a)
-> IO ()
glistSizeOf' :: f a
-> [Size]
glistAlignment' :: f a
-> [Alignment]
instance (GStorable' f) => GStorable' (M1 i t f) where
{-# 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
{-# 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
{-# 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
{-# 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
{-# 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
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)
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
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
{-# 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)
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
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
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)
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)
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)]
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' = undefined
gpokeByteOff' = undefined
glistSizeOf' = undefined
glistAlignment' = undefined
#endif
{-# INLINE internalSizeOf #-}
internalSizeOf :: forall f p. (GStorable' f)
=> f p
-> Int
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 #-}
internalAlignment :: forall f p. (GStorable' f)
=> f p
-> 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 #-}
internalPeekByteOff :: forall f p b. (KnownNat (NoFields f), GStorable' f)
=> Ptr b
-> Offset
-> IO (f p)
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 #-}
internalPokeByteOff :: forall f p b. (KnownNat (NoFields f), GStorable' f)
=> Ptr b
-> Offset
-> f p
-> 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 #-}
internalOffsets :: forall f p. (GStorable' f)
=> f p
-> [Offset]
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)
class GStorable a where
{-# INLINE gsizeOf #-}
{-# INLINE galignment #-}
{-# INLINE gpeekByteOff #-}
{-# INLINE gpokeByteOff #-}
gsizeOf :: a
-> Int
galignment :: a
-> Int
gpeekByteOff :: Ptr b
-> Int
-> IO a
gpokeByteOff :: Ptr b
-> Int
-> a
-> IO ()
#ifdef GSTORABLE_SUMTYPES
default gsizeOf :: (ConstraintsSize a, GStorableChoice a)
=> a -> Int
gsizeOf = Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1)) -> a -> Int
forall (choice :: Bool) a (proxy :: Bool -> *).
GStorableChoice' choice a =>
proxy choice -> a -> Int
chSizeOf (Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1))
forall k (t :: k). Proxy t
Proxy :: Proxy (IsSumType (Rep a)))
default galignment :: (ConstraintsAlignment a, GStorableChoice a)
=> a -> Int
galignment = Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1)) -> a -> Int
forall (choice :: Bool) a (proxy :: Bool -> *).
GStorableChoice' choice a =>
proxy choice -> a -> Int
chAlignment (Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1))
forall k (t :: k). Proxy t
Proxy :: Proxy (IsSumType (Rep a)))
default gpeekByteOff :: (GStorableChoice a, ConstraintsPeek a)
=> Ptr b -> Int -> IO a
gpeekByteOff = Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1))
-> Ptr b -> Int -> IO a
forall (choice :: Bool) a (proxy :: Bool -> *) b.
GStorableChoice' choice a =>
proxy choice -> Ptr b -> Int -> IO a
chPeekByteOff (Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1))
forall k (t :: k). Proxy t
Proxy :: Proxy (IsSumType (Rep a)))
default gpokeByteOff :: (GStorableChoice a, ConstraintsPoke a)
=> Ptr b -> Int -> a -> IO ()
gpokeByteOff = Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1))
-> Ptr b -> Int -> a -> IO ()
forall (choice :: Bool) a (proxy :: Bool -> *) b.
GStorableChoice' choice a =>
proxy choice -> Ptr b -> Int -> a -> IO ()
chPokeByteOff (Proxy (IsSumType' (CmpNat (SumArity (Rep a)) 1))
forall k (t :: k). Proxy t
Proxy :: Proxy (IsSumType (Rep a)))
#else
default gsizeOf :: (Generic a, GStorable' (Rep a))
=> a -> Int
gsizeOf _ = internalSizeOf (undefined :: Rep a p)
default galignment :: (Generic a, GStorable' (Rep a))
=> a -> Int
galignment _ = internalAlignment (undefined :: Rep a p)
default gpeekByteOff :: ( KnownNat (NoFields (Rep a))
, Generic a, GStorable' (Rep a))
=> Ptr b -> Int -> IO a
gpeekByteOff ptr offset = to <$> internalPeekByteOff ptr offset
default gpokeByteOff :: ( KnownNat (NoFields (Rep a))
, Generic a, GStorable' (Rep a))
=> Ptr b -> Int -> a -> IO ()
gpokeByteOff ptr offset x = internalPokeByteOff ptr offset (from x)
#endif
#ifdef GSTORABLE_SUMTYPES
type GStorableChoice a = GStorableChoice' (IsSumType (Rep a)) a
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 ()
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 :: proxy 'True -> a -> Int
chSizeOf proxy 'True
_ a
_ = [(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 = (Int
word8sInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:Rep a Any -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
gsizeOfSum' (forall p. Rep a p
forall a. HasCallStack => a
undefined :: Rep a p)Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[])
aligns :: [Int]
aligns = (Int
word8aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:Rep a Any -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
alignOfSum' (forall p. Rep a p
forall a. HasCallStack => a
undefined :: Rep a p)Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[])
word8s :: Int
word8s = Word8 -> Int
forall a. Storable a => a -> Int
sizeOf (Word8
forall a. HasCallStack => a
undefined :: Word8)
word8a :: Int
word8a = Word8 -> Int
forall a. Storable a => a -> Int
alignment (Word8
forall a. HasCallStack => a
undefined :: Word8)
chAlignment :: proxy 'True -> a -> Int
chAlignment proxy 'True
_ a
_ = [Int] -> Int
calcAlignment ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int
word8aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:Int
alignInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[])
where align :: Int
align = Rep a Any -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
alignOfSum' (forall p. Rep a p
forall a. HasCallStack => a
undefined :: Rep a p)
word8a :: Int
word8a = Word8 -> Int
forall a. Storable a => a -> Int
alignment (Word8
forall a. HasCallStack => a
undefined :: Word8)
chPeekByteOff :: proxy 'True -> Ptr b -> Int -> IO a
chPeekByteOff proxy 'True
_ Ptr b
ptr Int
off = do
let proxy :: Proxy 'True
proxy = (Proxy 'True
forall k (t :: k). Proxy t
Proxy :: Proxy True)
Word8
choice <- Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
off :: IO Word8
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
<$> Int -> Ptr b -> Int -> IO (Rep a Any)
forall (f :: * -> *) b p.
GStorableSum' f =>
Int -> Ptr b -> Int -> IO (f p)
gpeekByteOffSum' (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
choice) Ptr b
ptr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy 'True -> a -> Int
forall (choice :: Bool) a (proxy :: Bool -> *).
GStorableChoice' choice a =>
proxy choice -> a -> Int
chAlignment Proxy 'True
proxy (a
forall a. HasCallStack => a
undefined :: a))
chPokeByteOff :: proxy 'True -> Ptr b -> Int -> a -> IO ()
chPokeByteOff proxy 'True
_ Ptr b
ptr Int
off a
v = do
let proxy :: Proxy 'True
proxy = (Proxy 'True
forall k (t :: k). Proxy t
Proxy :: Proxy True)
Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptr Int
off (a -> Word8
forall a.
(KnownNat (SumArity (Rep a)), GStorableSum' (Rep a), Generic a) =>
a -> Word8
internalTagValue a
v Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
1)
Ptr b -> Int -> Rep a Any -> IO ()
forall (f :: * -> *) b p.
GStorableSum' f =>
Ptr b -> Int -> f p -> IO ()
gpokeByteOffSum' Ptr b
ptr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy 'True -> a -> Int
forall (choice :: Bool) a (proxy :: Bool -> *).
GStorableChoice' choice a =>
proxy choice -> a -> Int
chAlignment Proxy 'True
proxy a
v) (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
v)
instance (ConstraintsAll a, IsSumType (Rep a) ~ False) => GStorableChoice' False a where
{-# INLINE chSizeOf #-}
{-# INLINE chPeekByteOff #-}
{-# INLINE chPokeByteOff #-}
{-# INLINE chAlignment #-}
chSizeOf :: proxy 'False -> a -> Int
chSizeOf proxy 'False
_ 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)
chAlignment :: proxy 'False -> a -> Int
chAlignment proxy 'False
_ 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)
chPeekByteOff :: proxy 'False -> Ptr b -> Int -> IO a
chPeekByteOff proxy 'False
_ 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
chPokeByteOff :: proxy 'False -> Ptr b -> Int -> a -> IO ()
chPokeByteOff proxy 'False
_ 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)
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
type family ConstraintsSA' (t :: Bool) a where
ConstraintsSA' True a = (Generic a, GStorableSum' (Rep a))
ConstraintsSA' False a = (Generic a, GStorable' (Rep a))
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))
internalTagValue :: ( KnownNat (SumArity (Rep a))
, GStorableSum' (Rep a), Generic a)
=> a -> Word8
internalTagValue :: a -> Word8
internalTagValue (a
a :: a) = Rep a Any -> Int -> Word8
forall (f :: * -> *) p. GStorableSum' f => f p -> Int -> Word8
seeFirstByte' (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
a) (Rep a Any -> Int
forall (f :: * -> *) p. KnownNat (SumArity f) => f p -> Int
sumArity (forall p. Rep a p
forall a. HasCallStack => a
undefined :: Rep a p))
class GStorableSum' f where
seeFirstByte' :: f p -> Int -> Word8
gsizeOfSum' :: f p -> Int
alignOfSum' :: f p -> Int
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 D t f p -> Int -> Word8
seeFirstByte' (M1 f p
v) Int
acc = f p -> Int -> Word8
forall (f :: * -> *) p. GStorableSum' f => f p -> Int -> Word8
seeFirstByte' f p
v Int
acc
gsizeOfSum' :: M1 D t f p -> Int
gsizeOfSum' (M1 f p
v) = f p -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
gsizeOfSum' f p
v
alignOfSum' :: M1 D t f p -> Int
alignOfSum' (M1 f p
v) = f p -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
alignOfSum' f p
v
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO (M1 D t f p)
gpeekByteOffSum' Int
ch Ptr b
ptr Int
off = f p -> M1 D t f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D t f p) -> IO (f p) -> IO (M1 D t f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Ptr b -> Int -> IO (f p)
forall (f :: * -> *) b p.
GStorableSum' f =>
Int -> Ptr b -> Int -> IO (f p)
gpeekByteOffSum' Int
ch Ptr b
ptr Int
off
gpokeByteOffSum' :: Ptr b -> Int -> M1 D t f p -> IO ()
gpokeByteOffSum' Ptr b
ptr Int
off (M1 f p
v) = Ptr b -> Int -> f p -> IO ()
forall (f :: * -> *) b p.
GStorableSum' f =>
Ptr b -> Int -> f p -> IO ()
gpokeByteOffSum' Ptr b
ptr Int
off f p
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 C t f p -> Int -> Word8
seeFirstByte' (M1 f p
v) Int
acc = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
acc
gsizeOfSum' :: M1 C t f p -> Int
gsizeOfSum' (M1 f p
v) = f p -> Int
forall (f :: * -> *) p. GStorable' f => f p -> Int
internalSizeOf f p
v
alignOfSum' :: M1 C t f p -> Int
alignOfSum' (M1 f p
v) = f p -> Int
forall (f :: * -> *) p. GStorable' f => f p -> Int
internalAlignment f p
v
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO (M1 C t f p)
gpeekByteOffSum' Int
_ Ptr b
ptr Int
off = f p -> M1 C t f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C t f p) -> IO (f p) -> IO (M1 C t f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr b -> Int -> IO (f p)
forall (f :: * -> *) p b.
(KnownNat (NoFields f), GStorable' f) =>
Ptr b -> Int -> IO (f p)
internalPeekByteOff Ptr b
ptr Int
off
gpokeByteOffSum' :: Ptr b -> Int -> M1 C t f p -> IO ()
gpokeByteOffSum' Ptr b
ptr Int
off M1 C t f p
v = Ptr b -> Int -> M1 C t f p -> IO ()
forall (f :: * -> *) p b.
(KnownNat (NoFields f), GStorable' f) =>
Ptr b -> Int -> f p -> IO ()
internalPokeByteOff Ptr b
ptr Int
off M1 C t f p
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' :: (:+:) f g p -> Int -> Word8
seeFirstByte' (L1 f p
l) Int
acc = f p -> Int -> Word8
forall (f :: * -> *) p. GStorableSum' f => f p -> Int -> Word8
seeFirstByte' f p
l (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
- (g Any -> Int
forall (f :: * -> *) p. KnownNat (SumArity f) => f p -> Int
sumArity (forall p. g p
forall a. HasCallStack => a
undefined :: g p))
seeFirstByte' (R1 g p
r) Int
acc = g p -> Int -> Word8
forall (f :: * -> *) p. GStorableSum' f => f p -> Int -> Word8
seeFirstByte' g p
r Int
acc
gsizeOfSum' :: (:+:) f g p -> Int
gsizeOfSum' (:+:) f g p
_ = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (f Any -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
gsizeOfSum' (forall p. f p
forall a. HasCallStack => a
undefined :: f p)) (g Any -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
gsizeOfSum' (forall p. g p
forall a. HasCallStack => a
undefined :: g p))
alignOfSum' :: (:+:) f g p -> Int
alignOfSum' (:+:) f g p
_ = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (f Any -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
alignOfSum' (forall p. f p
forall a. HasCallStack => a
undefined :: f p)) (g Any -> Int
forall (f :: * -> *) p. GStorableSum' f => f p -> Int
alignOfSum' (forall p. g p
forall a. HasCallStack => a
undefined :: g p))
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO ((:+:) f g p)
gpeekByteOffSum' Int
choice Ptr b
ptr Int
off = if Int
arityL Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
choice
then f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f p -> (:+:) f g p) -> IO (f p) -> IO ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Ptr b -> Int -> IO (f p)
forall (f :: * -> *) b p.
GStorableSum' f =>
Int -> Ptr b -> Int -> IO (f p)
gpeekByteOffSum' Int
choice Ptr b
ptr Int
off
else g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g p -> (:+:) f g p) -> IO (g p) -> IO ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Ptr b -> Int -> IO (g p)
forall (f :: * -> *) b p.
GStorableSum' f =>
Int -> Ptr b -> Int -> IO (f p)
gpeekByteOffSum' (Int
choice Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
arityL) Ptr b
ptr Int
off
where arityL :: Int
arityL = f Any -> Int
forall (f :: * -> *) p. KnownNat (SumArity f) => f p -> Int
sumArity (forall p. f p
forall a. HasCallStack => a
undefined :: f p)
gpokeByteOffSum' :: Ptr b -> Int -> (:+:) f g p -> IO ()
gpokeByteOffSum' Ptr b
ptr Int
off (R1 g p
v) = Ptr b -> Int -> g p -> IO ()
forall (f :: * -> *) b p.
GStorableSum' f =>
Ptr b -> Int -> f p -> IO ()
gpokeByteOffSum' Ptr b
ptr Int
off g p
v
gpokeByteOffSum' Ptr b
ptr Int
off (L1 f p
v) = Ptr b -> Int -> f p -> IO ()
forall (f :: * -> *) b p.
GStorableSum' f =>
Ptr b -> Int -> f p -> IO ()
gpokeByteOffSum' Ptr b
ptr Int
off f p
v
instance (GStorableSum' f) => GStorableSum' (M1 S t f) where
seeFirstByte' :: M1 S t f p -> Int -> Word8
seeFirstByte' M1 S t f p
_ Int
_ = [Char] -> Word8
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't be here"
gsizeOfSum' :: M1 S t f p -> Int
gsizeOfSum' M1 S t f p
_ = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't be here"
alignOfSum' :: M1 S t f p -> Int
alignOfSum' M1 S t f p
_ = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't be here"
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO (M1 S t f p)
gpeekByteOffSum' Int
_ Ptr b
_ Int
_ = [Char] -> IO (M1 S t f p)
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't be here"
gpokeByteOffSum' :: Ptr b -> Int -> M1 S t f p -> IO ()
gpokeByteOffSum' Ptr b
_ Int
_ M1 S t f p
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Shouldn't be here"
instance GStorableSum' (f :*: g) where
seeFirstByte' :: (:*:) f g p -> Int -> Word8
seeFirstByte' (f p
l :*: g p
g) Int
acc = Word8
forall a. HasCallStack => a
undefined
gsizeOfSum' :: (:*:) f g p -> Int
gsizeOfSum' (:*:) f g p
_ = Int
forall a. HasCallStack => a
undefined
alignOfSum' :: (:*:) f g p -> Int
alignOfSum' (:*:) f g p
_ = Int
forall a. HasCallStack => a
undefined
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO ((:*:) f g p)
gpeekByteOffSum' Int
_ Ptr b
_ Int
_ = IO ((:*:) f g p)
forall a. HasCallStack => a
undefined
gpokeByteOffSum' :: Ptr b -> Int -> (:*:) f g p -> IO ()
gpokeByteOffSum' Ptr b
_ Int
_ (:*:) f g p
_ = IO ()
forall a. HasCallStack => a
undefined
instance GStorableSum' (K1 i a) where
seeFirstByte' :: K1 i a p -> Int -> Word8
seeFirstByte' K1 i a p
_ Int
acc = Word8
forall a. HasCallStack => a
undefined
gsizeOfSum' :: K1 i a p -> Int
gsizeOfSum' K1 i a p
_ = Int
forall a. HasCallStack => a
undefined
alignOfSum' :: K1 i a p -> Int
alignOfSum' K1 i a p
_ = Int
forall a. HasCallStack => a
undefined
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO (K1 i a p)
gpeekByteOffSum' Int
_ Ptr b
_ Int
_ = IO (K1 i a p)
forall a. HasCallStack => a
undefined
gpokeByteOffSum' :: Ptr b -> Int -> K1 i a p -> IO ()
gpokeByteOffSum' Ptr b
_ Int
_ K1 i a p
_ = IO ()
forall a. HasCallStack => a
undefined
instance GStorableSum' (U1) where
seeFirstByte' :: U1 p -> Int -> Word8
seeFirstByte' U1 p
_ Int
_ = Word8
forall a. HasCallStack => a
undefined
gsizeOfSum' :: U1 p -> Int
gsizeOfSum' U1 p
_ = Int
forall a. HasCallStack => a
undefined
alignOfSum' :: U1 p -> Int
alignOfSum' U1 p
_ = Int
forall a. HasCallStack => a
undefined
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO (U1 p)
gpeekByteOffSum' Int
_ Ptr b
_ Int
_ = IO (U1 p)
forall a. HasCallStack => a
undefined
gpokeByteOffSum' :: Ptr b -> Int -> U1 p -> IO ()
gpokeByteOffSum' Ptr b
_ Int
_ U1 p
_ = IO ()
forall a. HasCallStack => a
undefined
instance GStorableSum' (V1) where
seeFirstByte' :: V1 p -> Int -> Word8
seeFirstByte' V1 p
_ Int
_ = Word8
forall a. HasCallStack => a
undefined
gsizeOfSum' :: V1 p -> Int
gsizeOfSum' V1 p
_ = Int
forall a. HasCallStack => a
undefined
alignOfSum' :: V1 p -> Int
alignOfSum' V1 p
_ = Int
forall a. HasCallStack => a
undefined
gpeekByteOffSum' :: Int -> Ptr b -> Int -> IO (V1 p)
gpeekByteOffSum' Int
_ Ptr b
_ Int
_ = IO (V1 p)
forall a. HasCallStack => a
undefined
gpokeByteOffSum' :: Ptr b -> Int -> V1 p -> IO ()
gpokeByteOffSum' Ptr b
_ Int
_ V1 p
_ = IO ()
forall a. HasCallStack => a
undefined
#endif
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