derive-storable 0.1.2.0 → 0.2.0.0

raw patch · 14 files changed

+1185/−865 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +18/−1
• derive-storable.cabal +16/−26
• src/Foreign/Storable/Generic/Internal.hs +244/−45
• src/Foreign/Storable/Generic/Tools/TypeFuns.hs +41/−0
• test/Basic/MemoryCSpec.hs +28/−1
• test/Basic/TestCases.hs +249/−5
• test/Basic/cbits/TestCases.c +585/−0
• test/GenericRep/GenericType.hs +0/−239
• test/Spec/Foreign/Storable/Generic/Internal/GStorable'Spec.hs +0/−218
• test/Spec/Foreign/Storable/Generic/Internal/GStorableSpec.hs +0/−130
• test/Spec/Foreign/Storable/Generic/InternalSpec.hs +0/−158
• test/Spec/Foreign/Storable/Generic/ToolsSpec.hs +0/−29
• test/Spec/Spec.hs +0/−13

@@ -1,5 +1,9 @@ # Revision history for derive-storable +## 0.2.0.0  -- 2020-03-01++* Added support for sum types enabled through additional option.+ ## 0.1.2.0  -- 2018-04-30  * Added U1 instance for GHC.Generics.

@@ -4,10 +4,27 @@  The `derive-storable` package allows you to automatically generate Storable instances for your datatypes. It uses GHC.Generics, which allows the coders to derive certain instances automatically. To derive a (G)Storable instance, the data-type has to: -* have only one constructor.+* ~~have only one constructor~~ There is now a `sumtypes` option for data-types with multiple constructors. See **Sum types** section for more. * all fields of the constructor need to be GStorable. * implement a Generic instance (`derive (Generic)`) +### Sum types++To enable support for sum types, add a `-f sumtypes` option to `cabal new-build` or `cabal new-configure`. The library discerns between sum and non-sum types. Non-sum types have the same memory layout as C structs, while sum types correspond to tagged unions: ++```c+struct datatype {+    unsigned char tag;+    union { +        constructor1 a;+        constructor2 b;+        ...+    } val;+};++```++Note - while it is possible to have an instance for a self/mutually recursive data-type, using methods for the data-type will result in infinite loop. So there is no support for recursion in data-types.  ### Note on performance 

@@ -1,6 +1,6 @@ name:                derive-storable -version:             0.1.2.0+version:             0.2.0.0 synopsis:            Derive Storable instances with GHC.Generics.             description:         Derive Storable instances with GHC.Generics. The derived Storable instances have the same alignment as C structs.@@ -20,14 +20,23 @@ extra-source-files:  ChangeLog.md README.md  cabal-version:       >=1.10-tested-with:         GHC==8.0.1, GHC==8.0.2, GHC==8.2.1, GHC==8.4.1, GHC==8.4.2+tested-with:         GHC==8.0.2, GHC==8.2.2, GHC==8.4.2, GHC==8.6.4, GHC==8.8.1 +Flag sumtypes+  Description:   Enable support for non-recursive sum types.+  Default:       False+ library-  exposed-modules:     Foreign.Storable.Generic, Foreign.Storable.Generic.Tools-                     , Foreign.Storable.Generic.Internal, Foreign.Storable.Generic.Instances       +  exposed-modules:     Foreign.Storable.Generic +                     , Foreign.Storable.Generic.Internal+                     , Foreign.Storable.Generic.Instances       +                     , Foreign.Storable.Generic.Tools+                     , Foreign.Storable.Generic.Tools.TypeFuns   build-depends:       base >=4.8 && < 5   hs-source-dirs:      src   default-language:    Haskell2010+  if flag(sumtypes)+    cpp-options: -DGSTORABLE_SUMTYPES  benchmark benchmark   type:                exitcode-stdio-1.0@@ -38,8 +47,6 @@   build-depends:       base >= 4.8 && < 5, deepseq, criterion >= 1.1.0                     ,  derive-storable  -- test-suite c_alignment   type:                exitcode-stdio-1.0   @@ -50,30 +57,13 @@                      , Foreign.Storable.Generic.Instances                      , Foreign.Storable.Generic.Internal                      , Foreign.Storable.Generic.Tools+                     , Foreign.Storable.Generic.Tools.TypeFuns                      , TestCases -     build-depends:       base >= 4.8 && < 5, hspec >= 2.4, QuickCheck >= 2.10      default-language:    Haskell2010--test-suite spec-  type:                  exitcode-stdio-1.0-  hs-source-dirs:        src/ test/Spec test/Basic test/GenericRep/-  Main-is:               Spec.hs-  other-modules:         Foreign.Storable.Generic-                       , Foreign.Storable.Generic.Instances-                       , Foreign.Storable.Generic.Internal-                       , Foreign.Storable.Generic.Internal.GStorable'Spec-                       , Foreign.Storable.Generic.Internal.GStorableSpec-                       , Foreign.Storable.Generic.InternalSpec-                       , Foreign.Storable.Generic.Tools-                       , Foreign.Storable.Generic.ToolsSpec-                       , GenericType--  build-depends:       base >= 4.8 && < 5, hspec >= 2.4, QuickCheck >= 2.10--  default-language:    Haskell2010-+  if flag(sumtypes)+    cpp-options: -DGSTORABLE_SUMTYPES  source-repository head   type:                git

@@ -9,16 +9,28 @@  -} -{-#LANGUAGE FlexibleInstances #-}-{-#LANGUAGE FlexibleContexts #-}-{-#LANGUAGE DefaultSignatures #-}-{-#LANGUAGE TypeOperators #-}-{-#LANGUAGE ScopedTypeVariables #-}+{-#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 (..),+#ifdef GSTORABLE_SUMTYPES+     GStorableSum'(..),+     GStorableChoice'(..),+     GStorableChoice,+     internalTagValue,+#endif      internalSizeOf,      internalAlignment,      internalPeekByteOff,@@ -26,17 +38,21 @@      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 @@ -59,10 +75,6 @@                   -> (f a)  -- ^ The element to write, wrapped in GHC.Generic metadata.                   -> IO () -    -- | Calculates the number of type's/struct's fields.-    gnumberOf' :: f a -- ^ GHC.Generic information about a given type/struct.-               -> Int -- ^ Size.-     -- | Calculates the sizes of type's/struct's fields.     glistSizeOf' :: f a    -- ^ GHC.Generic information about a given type/struct.                   -> [Size] -- ^ List of sizes.@@ -80,8 +92,6 @@     {-# INLINE gpokeByteOff' #-}     gpokeByteOff' offsets ix ptr offset (M1 x) = gpokeByteOff' offsets ix ptr offset x      --    gnumberOf' (M1 v) = gnumberOf' v     glistSizeOf' _ = glistSizeOf' (undefined :: f p)     glistAlignment' _ = glistAlignment' (undefined :: f p) @@ -93,29 +103,28 @@     {-# INLINE gpokeByteOff' #-}     gpokeByteOff' offsets ix ptr offset (U1) = return ()     --    gnumberOf' (U1)   = 0     glistSizeOf'    _ = []     glistAlignment' _ = [] -instance (GStorable' f, GStorable' g) => GStorable' (f :*: g) where+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' offsets ix ptr offset = (:*:) <$> peeker new_ix <*>  peeker ix+    gpeekByteOff' offsets ix ptr offset = (:*:) <$> peeker1 new_ix <*>  peeker2 ix         where new_ix =  ix - n2                                        -- The new index for the left part of the tree.-              n2 = gnumberOf' (undefined :: g a)                       -- Number of elements for the right part of the tree-              peeker n_ix = gpeekByteOff' offsets n_ix ptr offset      -- gpeekByteOff' wrapped to peek into subtrees.+              n2 = noFields (undefined :: g a)                       -- Number of elements for the right part of the tree+              peeker1 n_ix = gpeekByteOff' offsets n_ix ptr offset      -- gpeekByteOff' wrapped to peek into subtrees.+              peeker2 n_ix = gpeekByteOff' offsets n_ix ptr offset      -- gpeekByteOff' wrapped to peek into subtrees.     -- Tree like traversal for writing the type.     {-# INLINE gpokeByteOff' #-}-    gpokeByteOff' offsets ix ptr offset (x :*: y) = peeker new_ix x >> peeker ix y+    gpokeByteOff' offsets ix ptr offset (x :*: y) = peeker1 new_ix x >> peeker2 ix y         where new_ix = ix - n2                                 -              n2 = gnumberOf' (undefined :: g a)               -- Number of elements for the right part of the tree.-              peeker n_ix z = gpokeByteOff' offsets n_ix ptr offset z  -- gpokeByteOff' wrapped to peek into the subtree-+              n2 = noFields (undefined :: g a)               -- Number of elements for the right part of the tree.+              peeker1 n_ix z = gpokeByteOff' offsets n_ix ptr offset z  -- gpokeByteOff' wrapped to peek into the subtree+              peeker2 n_ix z = gpokeByteOff' offsets n_ix ptr offset z  -- gpokeByteOff' wrapped to peek into the subtree   -    gnumberOf' _ = gnumberOf' (undefined :: f a) + gnumberOf' (undefined :: g a)     -- Concatenate the lists.      glistSizeOf' _ = glistSizeOf' (undefined :: f a) ++ glistSizeOf' (undefined :: g a)     -- Concatenate the lists.@@ -130,8 +139,6 @@         where off1 = inline (offsets !! ix)   -    -- When we use the contructor, just return one.-    gnumberOf' _ = 1     -- When the constructor is used, return the size of      -- the constructed type in a list.     glistSizeOf' _ = [gsizeOf (undefined :: a)]@@ -140,6 +147,16 @@     glistAlignment' _ = [galignment (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+ -- These functions were moved outside GStorable type class. -- They take generic representations as input. @@ -162,24 +179,24 @@  {-# INLINE internalPeekByteOff #-} -- | View the variable under a pointer, with offset.-internalPeekByteOff :: forall f p b. (GStorable' f) +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 off  = gpeekByteOff' offsets ix ptr off     where offsets = internalOffsets (undefined :: f p)-          ix      = gnumberOf' (undefined :: f p) - 1+          ix      = noFields (undefined :: f p) - 1  {-# INLINE internalPokeByteOff #-} -- | Write the variable under the pointer, with offset.-internalPokeByteOff :: forall f p b. (GStorable' f) +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 off rep = gpokeByteOff' offsets ix ptr off rep     where offsets = internalOffsets (undefined :: f p)-          ix      = gnumberOf' (undefined :: f p) - 1+          ix      = noFields (undefined :: f p) - 1  {-# INLINE internalOffsets #-} -- | Obtain the list of offsets@@ -192,41 +209,223 @@  -- | The class uses the default Generic based implementations to  -- provide Storable instances for types made from primitive types.--- Does not work on Algebraic Data Types with more than one constructor.+-- 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.-    {-# INLINE gsizeOf #-}     gsizeOf :: a   -- ^ Element of a given type. Can be undefined.             -> Int -- ^ Size.-    default gsizeOf :: (Generic a, GStorable' (Rep a))-                    => a -> Int-    gsizeOf _ = internalSizeOf (undefined :: Rep a p)           -- | Calculate the alignment of the type.-    {-# INLINE galignment #-}     galignment :: a   -- ^ Element of a given type. Can be undefined                  -> Int -- ^ Alignment.-    default galignment :: (Generic a, GStorable' (Rep a))-                         => a -> Int-    galignment _ = internalAlignment (undefined :: Rep a p) -+         -- | Read the variable from a given pointer.     gpeekByteOff :: Ptr b -- ^ Pointer to the variable                  -> Int   -- ^ Offset                  -> IO a  -- ^ Returned variable.-    default gpeekByteOff :: (Generic a, GStorable' (Rep a))-                         => Ptr b -> Int -> IO a-    {-# INLINE gpeekByteOff #-}-    gpeekByteOff ptr offset = to <$> internalPeekByteOff ptr offset-+         -- | Write the variable to a pointer.      gpokeByteOff :: Ptr b -- ^ Pointer to the variable.                   -> Int   -- ^ Offset.                  -> a     -- ^ The variable                  -> IO ()-    default gpokeByteOff :: (Generic a, GStorable' (Rep a))++#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 ()-    {-# INLINE gpokeByteOff #-}+    gpokeByteOff = chPokeByteOff (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++-- | 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

@@ -0,0 +1,41 @@+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE UndecidableInstances #-}++module Foreign.Storable.Generic.Tools.TypeFuns where++import Data.Proxy+import GHC.Generics+import GHC.TypeLits++type family SumArity (arg :: * -> *) where+    SumArity (M1 C _ t) = 1+    SumArity (M1 _ _ t) =  SumArity t+    SumArity  (f :+: g) = (SumArity f) + (SumArity g)+    -- There should be no more constructors within products, but who knows..   +    SumArity  (f :*: g) = (SumArity f) + (SumArity g)+    SumArity _          = 0++type family NoFields (arg :: * -> *) where+    NoFields (M1 _ _ t) =  NoFields t+    NoFields (f  :+: g) = (NoFields f) + (NoFields g)+    NoFields (f  :*: g) = (NoFields f) + (NoFields g)+    NoFields (K1  _  _) = 1+    NoFields _          = 0++type IsSumType (arg :: * -> *) = IsSumType' (CmpNat (SumArity arg) (1))++type family IsSumType' (ret :: Ordering) :: Bool where+    IsSumType' GT = True+    IsSumType' _  = False++noFields :: (KnownNat (NoFields f)) => f p -> Int+noFields (a :: f p) = fromIntegral.natVal $ (Proxy :: Proxy (NoFields f)) ++sumArity :: (KnownNat (SumArity f)) => f p -> Int+sumArity (a :: f p) = fromIntegral.natVal $ (Proxy :: Proxy (SumArity f)) 

@@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts#-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE CPP                 #-} module Main where  @@ -116,3 +117,29 @@         it "C18" $ property $ (same_fields    :: C18 -> Expectation)         it "C19" $ property $ (same_fields    :: C19 -> Expectation)         it "C20" $ property $ (same_fields    :: C20 -> Expectation)+#ifdef GSTORABLE_SUMTYPES+    describe "Test for same size - sums" $ do+        it "S0" $ property $ (same_size      :: S0 -> Expectation)+        it "S1" $ property $ (same_size      :: S1 -> Expectation)+        it "S2" $ property $ (same_size      :: S2 -> Expectation)+        it "S3" $ property $ (same_size      :: S3 -> Expectation)+        it "S4" $ property $ (same_size      :: S4 -> Expectation)+    describe "Test for same alignment - sums" $ do+        it "S0" $ property $ (same_alignment :: S0 -> Expectation)+        it "S1" $ property $ (same_alignment :: S1 -> Expectation)+        it "S2" $ property $ (same_alignment :: S2 -> Expectation)+        it "S3" $ property $ (same_alignment :: S3 -> Expectation)+        it "S4" $ property $ (same_alignment :: S4 -> Expectation)+    describe "Test for same offsets - sums" $ do+        it "S0" $ property $ (same_offsets   :: S0 -> Expectation)+        it "S1" $ property $ (same_offsets   :: S1 -> Expectation)+        it "S2" $ property $ (same_offsets   :: S2 -> Expectation)+        it "S3" $ property $ (same_offsets   :: S3 -> Expectation)+        it "S4" $ property $ (same_offsets   :: S4 -> Expectation)+    describe "Test for same fields - sums" $ do+        it "S0" $ property $ (same_fields    :: S0 -> Expectation)+        it "S1" $ property $ (same_fields    :: S1 -> Expectation)+        it "S2" $ property $ (same_fields    :: S2 -> Expectation)+        it "S3" $ property $ (same_fields    :: S3 -> Expectation)+        it "S4" $ property $ (same_fields    :: S4 -> Expectation)+#endif

@@ -1,13 +1,19 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CApiFFI #-}+{-# LANGUAGE CPP     #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE UndecidableInstances #-}  module TestCases where -import GHC.Generics (Generic, Rep, from)+import GHC.Generics hiding (C1,S1)+import GHC.TypeLits  import Foreign.C.Types import Foreign.Storable import Foreign.Storable.Generic@@ -47,10 +53,36 @@   poke ptr val   return ptr -goffsets :: (GStorable' (Rep a), GStorable a, Generic a) => a -> [Int16]-goffsets v = map fromIntegral $ internalOffsets (from v) -data C0 = C0 +class SumOffsets' f where+    sumOffsets' :: f p -> [Offset]++instance (SumOffsets' f) => SumOffsets' (M1 D t f) where+    sumOffsets' (M1 v) = sumOffsets' v++instance (GStorable' f, SumOffsets' f) => SumOffsets' (M1 C t f) where+    sumOffsets' (M1 v) = internalOffsets v++instance (SumOffsets' f, SumOffsets' g) => SumOffsets' (f :+: g) where+    sumOffsets' (L1 v) = sumOffsets' v+    sumOffsets' (R1 v) = sumOffsets' v++instance SumOffsets' (M1 S t f) where+    sumOffsets' _ = undefined+instance SumOffsets' (f :*: g) where+    sumOffsets' _ = undefined+instance SumOffsets' (K1 i a) where+    sumOffsets' _ = undefined+instance SumOffsets' (U1) where+    sumOffsets' _ = undefined+instance SumOffsets' (V1) where+    sumOffsets' _ = undefined+++goffsets :: (SumOffsets' (Rep a), GStorable a, Generic a) => a -> [Int16]+goffsets v = map fromIntegral $ sumOffsets' (from v)++data C0 = C0     deriving (Show, Eq, Generic, GStorable)  instance Checkable C0 where@@ -549,3 +581,215 @@ foreign import ccall getSizeC20 :: IO Int16 foreign import ccall getAlignmentC20 :: IO Int16 +#ifdef GSTORABLE_SUMTYPES+data S0 = S0_1 Int8+        | S0_2 Int16+    deriving (Show, Eq, Generic, GStorable)++instance Checkable S0 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsS0 ptr1 ptr2+    checkOffsets (S0_1 a) offs = (==1) <$> checkOffsetsS0_1 offs+    checkOffsets (S0_2 a) offs = (==1) <$> checkOffsetsS0_2 offs+    getSize        a          = fromIntegral <$> getSizeS0+    getAlignment   a          = fromIntegral <$> getAlignmentS0+    new (S0_1 a) = do+        ptr <- newS0_1 a+        return ptr+    new (S0_2 a) = do+        ptr <- newS0_2 a+        return ptr++instance Arbitrary S0 where +    arbitrary = oneof [ S0_1 <$> arbitrary+                      , S0_2 <$> arbitrary+                      ]+foreign import ccall newS0_1 :: Int8 -> IO (Ptr S0)+foreign import ccall newS0_2 :: Int16 -> IO (Ptr S0)+foreign import ccall checkFieldsS0 :: Ptr S0 -> Ptr S0 -> IO Int8+foreign import ccall checkOffsetsS0 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS0_1 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS0_2 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeS0 :: IO Int16+foreign import ccall getAlignmentS0 :: IO Int16++data S1 = S1_1 Int32 Int8+        | S1_2 Double Int32 Int8 Int8+        | S1_3 Float+    deriving (Show, Eq, Generic, GStorable)++instance Checkable S1 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsS1 ptr1 ptr2+    checkOffsets (S1_1 a b) offs = (==1) <$> checkOffsetsS1_1 offs+    checkOffsets (S1_2 a b c d) offs = (==1) <$> checkOffsetsS1_2 offs+    checkOffsets (S1_3 a) offs = (==1) <$> checkOffsetsS1_3 offs+    getSize        a          = fromIntegral <$> getSizeS1+    getAlignment   a          = fromIntegral <$> getAlignmentS1+    new (S1_1 a b) = do+        ptr <- newS1_1 a b+        return ptr+    new (S1_2 a b c d) = do+        ptr <- newS1_2 a b c d+        return ptr+    new (S1_3 a) = do+        ptr <- newS1_3 a+        return ptr++instance Arbitrary S1 where +    arbitrary = oneof [ S1_1 <$> arbitrary <*> arbitrary+                      , S1_2 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+                      , S1_3 <$> arbitrary+                      ]+foreign import ccall newS1_1 :: Int32 -> Int8 -> IO (Ptr S1)+foreign import ccall newS1_2 :: Double -> Int32 -> Int8 -> Int8 -> IO (Ptr S1)+foreign import ccall newS1_3 :: Float -> IO (Ptr S1)+foreign import ccall checkFieldsS1 :: Ptr S1 -> Ptr S1 -> IO Int8+foreign import ccall checkOffsetsS1 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS1_1 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS1_2 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS1_3 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeS1 :: IO Int16+foreign import ccall getAlignmentS1 :: IO Int16++data S2 = S2_1 C13 Int8+        | S2_2 C2 C1+        | S2_3 C0+    deriving (Show, Eq, Generic, GStorable)++instance Checkable S2 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsS2 ptr1 ptr2+    checkOffsets (S2_1 a b) offs = (==1) <$> checkOffsetsS2_1 offs+    checkOffsets (S2_2 a b) offs = (==1) <$> checkOffsetsS2_2 offs+    checkOffsets (S2_3 a) offs = (==1) <$> checkOffsetsS2_3 offs+    getSize        a          = fromIntegral <$> getSizeS2+    getAlignment   a          = fromIntegral <$> getAlignmentS2+    new (S2_1 a b) = do+        ptr_a <- newStorable a+        ptr <- newS2_1 ptr_a b+        free ptr_a+        return ptr+    new (S2_2 a b) = do+        ptr_a <- newStorable a+        ptr_b <- newStorable b+        ptr <- newS2_2 ptr_a ptr_b+        free ptr_a+        free ptr_b+        return ptr+    new (S2_3 a) = do+        ptr_a <- newStorable a+        ptr <- newS2_3 ptr_a+        free ptr_a+        return ptr++instance Arbitrary S2 where +    arbitrary = oneof [ S2_1 <$> arbitrary <*> arbitrary+                      , S2_2 <$> arbitrary <*> arbitrary+                      , S2_3 <$> arbitrary+                      ]+foreign import ccall newS2_1 :: Ptr C13 -> Int8 -> IO (Ptr S2)+foreign import ccall newS2_2 :: Ptr C2 -> Ptr C1 -> IO (Ptr S2)+foreign import ccall newS2_3 :: Ptr C0 -> IO (Ptr S2)+foreign import ccall checkFieldsS2 :: Ptr S2 -> Ptr S2 -> IO Int8+foreign import ccall checkOffsetsS2 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS2_1 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS2_2 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS2_3 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeS2 :: IO Int16+foreign import ccall getAlignmentS2 :: IO Int16++data S3 = S3_1 S1+        | S3_2 S2+        | S3_3 Int8+    deriving (Show, Eq, Generic, GStorable)++instance Checkable S3 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsS3 ptr1 ptr2+    checkOffsets (S3_1 a) offs = (==1) <$> checkOffsetsS3_1 offs+    checkOffsets (S3_2 a) offs = (==1) <$> checkOffsetsS3_2 offs+    checkOffsets (S3_3 a) offs = (==1) <$> checkOffsetsS3_3 offs+    getSize        a          = fromIntegral <$> getSizeS3+    getAlignment   a          = fromIntegral <$> getAlignmentS3+    new (S3_1 a) = do+        ptr_a <- newStorable a+        ptr <- newS3_1 ptr_a+        free ptr_a+        return ptr+    new (S3_2 a) = do+        ptr_a <- newStorable a+        ptr <- newS3_2 ptr_a+        free ptr_a+        return ptr+    new (S3_3 a) = do+        ptr <- newS3_3 a+        return ptr++instance Arbitrary S3 where +    arbitrary = oneof [ S3_1 <$> arbitrary+                      , S3_2 <$> arbitrary+                      , S3_3 <$> arbitrary+                      ]+foreign import ccall newS3_1 :: Ptr S1 -> IO (Ptr S3)+foreign import ccall newS3_2 :: Ptr S2 -> IO (Ptr S3)+foreign import ccall newS3_3 :: Int8 -> IO (Ptr S3)+foreign import ccall checkFieldsS3 :: Ptr S3 -> Ptr S3 -> IO Int8+foreign import ccall checkOffsetsS3 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS3_1 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS3_2 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS3_3 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeS3 :: IO Int16+foreign import ccall getAlignmentS3 :: IO Int16++data S4 = S4_1 C0+        | S4_2 C0+        | S4_3 C0+        | S4_4 C1+    deriving (Show, Eq, Generic, GStorable)++instance Checkable S4 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsS4 ptr1 ptr2+    checkOffsets (S4_1 a) offs = (==1) <$> checkOffsetsS4_1 offs+    checkOffsets (S4_2 a) offs = (==1) <$> checkOffsetsS4_2 offs+    checkOffsets (S4_3 a) offs = (==1) <$> checkOffsetsS4_3 offs+    checkOffsets (S4_4 a) offs = (==1) <$> checkOffsetsS4_4 offs+    getSize        a          = fromIntegral <$> getSizeS4+    getAlignment   a          = fromIntegral <$> getAlignmentS4+    new (S4_1 a) = do+        ptr_a <- newStorable a+        ptr <- newS4_1 ptr_a+        free ptr_a+        return ptr+    new (S4_2 a) = do+        ptr_a <- newStorable a+        ptr <- newS4_2 ptr_a+        free ptr_a+        return ptr+    new (S4_3 a) = do+        ptr_a <- newStorable a+        ptr <- newS4_3 ptr_a+        free ptr_a+        return ptr+    new (S4_4 a) = do+        ptr_a <- newStorable a+        ptr <- newS4_4 ptr_a+        free ptr_a+        return ptr++instance Arbitrary S4 where +    arbitrary = oneof [ S4_1 <$> arbitrary+                      , S4_2 <$> arbitrary+                      , S4_3 <$> arbitrary+                      , S4_4 <$> arbitrary+                      ]+foreign import ccall newS4_1 :: Ptr C0 -> IO (Ptr S4)+foreign import ccall newS4_2 :: Ptr C0 -> IO (Ptr S4)+foreign import ccall newS4_3 :: Ptr C0 -> IO (Ptr S4)+foreign import ccall newS4_4 :: Ptr C1 -> IO (Ptr S4)+foreign import ccall checkFieldsS4 :: Ptr S4 -> Ptr S4 -> IO Int8+foreign import ccall checkOffsetsS4 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS4_1 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS4_2 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS4_3 :: Ptr Int16 -> IO Int8+foreign import ccall checkOffsetsS4_4 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeS4 :: IO Int16+foreign import ccall getAlignmentS4 :: IO Int16++#endif

@@ -920,3 +920,588 @@     return alignof(C20); } +typedef struct S0_1{+    HsInt8 a;+} S0_1;++typedef struct S0_2{+    HsInt16 a;+} S0_2;++typedef union S0_union{+    S0_1 a;+    S0_2 b;+} S0_union;++typedef struct S0 {+    HsWord8 tag;+    S0_union val;+} S0;++S0 * newS0_1(HsInt8 a){+    S0 * ret = (S0*) malloc(sizeof(S0));+    ret->tag = 0;+    ret->val.a.a = a;+    return ret;+}++S0 * newS0_2(HsInt16 a){+    S0 * ret = (S0*) malloc(sizeof(S0));+    ret->tag = 1;+    ret->val.b.a = a;+    return ret;+}++void pokeS0_1(S0* un, HsInt8 a){+    un->tag = 0;+    un->val.a.a = a;+}++void pokeS0_2(S0* un, HsInt16 a){+    un->tag = 1;+    un->val.b.a = a;+}++int checkOffsetsS0_1(HsInt16 *offs){+    int a = offsetof(S0_1, a) == offs[0];+    return a;+}++int checkOffsetsS0_2(HsInt16 *offs){+    int a = offsetof(S0_2, a) == offs[0];+    return a;+}++int checkOffsetsS0(HsInt16 *offs){+    int t = offsetof(S0, tag) == offs[0];+    int v = offsetof(S0, val) == offs[1];+    return t && v;+}++int checkFieldsS0_1(S0_1* s1, S0_1* s2){+    int a = s1->a == s2->a;+    return a;+}++int checkFieldsS0_2(S0_2* s1, S0_2* s2){+    int a = s1->a == s2->a;+    return a;+}++int checkFieldsS0(S0* s1, S0* s2){+    if (s1->tag != s2->tag) return 0;+    if (s1->tag == 0) return checkFieldsS0_1(&s1->val.a,&s2->val.a);+    if (s1->tag == 1) return checkFieldsS0_2(&s1->val.b,&s2->val.b);+    return 0;+}++HsInt16 getSizeS0() {+    return sizeof(S0);+}++HsInt16 getAlignmentS0() {+    return alignof(S0);+}++typedef struct S1_1{+    HsInt32 a;+    HsInt8 b;+} S1_1;++typedef struct S1_2{+    HsDouble a;+    HsInt32 b;+    HsInt8 c;+    HsInt8 d;+} S1_2;++typedef struct S1_3{+    HsFloat a;+} S1_3;++typedef union S1_union{+    S1_1 a;+    S1_2 b;+    S1_3 c;+} S1_union;++typedef struct S1 {+    HsWord8 tag;+    S1_union val;+} S1;++S1 * newS1_1(HsInt32 a, HsInt8 b){+    S1 * ret = (S1*) malloc(sizeof(S1));+    ret->tag = 0;+    ret->val.a.a = a;+    ret->val.a.b = b;+    return ret;+}++S1 * newS1_2(HsDouble a, HsInt32 b, HsInt8 c, HsInt8 d){+    S1 * ret = (S1*) malloc(sizeof(S1));+    ret->tag = 1;+    ret->val.b.a = a;+    ret->val.b.b = b;+    ret->val.b.c = c;+    ret->val.b.d = d;+    return ret;+}++S1 * newS1_3(HsFloat a){+    S1 * ret = (S1*) malloc(sizeof(S1));+    ret->tag = 2;+    ret->val.c.a = a;+    return ret;+}++void pokeS1_1(S1* un, HsInt32 a, HsInt8 b){+    un->tag = 0;+    un->val.a.a = a;+    un->val.a.b = b;+}++void pokeS1_2(S1* un, HsDouble a, HsInt32 b, HsInt8 c, HsInt8 d){+    un->tag = 1;+    un->val.b.a = a;+    un->val.b.b = b;+    un->val.b.c = c;+    un->val.b.d = d;+}++void pokeS1_3(S1* un, HsFloat a){+    un->tag = 2;+    un->val.c.a = a;+}++int checkOffsetsS1_1(HsInt16 *offs){+    int a = offsetof(S1_1, a) == offs[0];+    int b = offsetof(S1_1, b) == offs[1];+    return a && b;+}++int checkOffsetsS1_2(HsInt16 *offs){+    int a = offsetof(S1_2, a) == offs[0];+    int b = offsetof(S1_2, b) == offs[1];+    int c = offsetof(S1_2, c) == offs[2];+    int d = offsetof(S1_2, d) == offs[3];+    return a && b && c && d;+}++int checkOffsetsS1_3(HsInt16 *offs){+    int a = offsetof(S1_3, a) == offs[0];+    return a;+}++int checkOffsetsS1(HsInt16 *offs){+    int t = offsetof(S1, tag) == offs[0];+    int v = offsetof(S1, val) == offs[1];+    return t && v;+}++int checkFieldsS1_1(S1_1* s1, S1_1* s2){+    int a = s1->a == s2->a;+    int b = s1->b == s2->b;+    return a && b;+}++int checkFieldsS1_2(S1_2* s1, S1_2* s2){+    int a = s1->a == s2->a;+    int b = s1->b == s2->b;+    int c = s1->c == s2->c;+    int d = s1->d == s2->d;+    return a && b && c && d;+}++int checkFieldsS1_3(S1_3* s1, S1_3* s2){+    int a = s1->a == s2->a;+    return a;+}++int checkFieldsS1(S1* s1, S1* s2){+    if (s1->tag != s2->tag) return 0;+    if (s1->tag == 0) return checkFieldsS1_1(&s1->val.a,&s2->val.a);+    if (s1->tag == 1) return checkFieldsS1_2(&s1->val.b,&s2->val.b);+    if (s1->tag == 2) return checkFieldsS1_3(&s1->val.c,&s2->val.c);+    return 0;+}++HsInt16 getSizeS1() {+    return sizeof(S1);+}++HsInt16 getAlignmentS1() {+    return alignof(S1);+}++typedef struct S2_1{+    C13 a;+    HsInt8 b;+} S2_1;++typedef struct S2_2{+    C2 a;+    C1 b;+} S2_2;++typedef struct S2_3{+    C0 a;+} S2_3;++typedef union S2_union{+    S2_1 a;+    S2_2 b;+    S2_3 c;+} S2_union;++typedef struct S2 {+    HsWord8 tag;+    S2_union val;+} S2;++S2 * newS2_1(C13* a, HsInt8 b){+    S2 * ret = (S2*) malloc(sizeof(S2));+    ret->tag = 0;+    ret->val.a.a = *a;+    ret->val.a.b = b;+    return ret;+}++S2 * newS2_2(C2* a, C1* b){+    S2 * ret = (S2*) malloc(sizeof(S2));+    ret->tag = 1;+    ret->val.b.a = *a;+    ret->val.b.b = *b;+    return ret;+}++S2 * newS2_3(C0* a){+    S2 * ret = (S2*) malloc(sizeof(S2));+    ret->tag = 2;+    ret->val.c.a = *a;+    return ret;+}++void pokeS2_1(S2* un, C13* a, HsInt8 b){+    un->tag = 0;+    un->val.a.a = *a;+    un->val.a.b = b;+}++void pokeS2_2(S2* un, C2* a, C1* b){+    un->tag = 1;+    un->val.b.a = *a;+    un->val.b.b = *b;+}++void pokeS2_3(S2* un, C0* a){+    un->tag = 2;+    un->val.c.a = *a;+}++int checkOffsetsS2_1(HsInt16 *offs){+    int a = offsetof(S2_1, a) == offs[0];+    int b = offsetof(S2_1, b) == offs[1];+    return a && b;+}++int checkOffsetsS2_2(HsInt16 *offs){+    int a = offsetof(S2_2, a) == offs[0];+    int b = offsetof(S2_2, b) == offs[1];+    return a && b;+}++int checkOffsetsS2_3(HsInt16 *offs){+    int a = offsetof(S2_3, a) == offs[0];+    return a;+}++int checkOffsetsS2(HsInt16 *offs){+    int t = offsetof(S2, tag) == offs[0];+    int v = offsetof(S2, val) == offs[1];+    return t && v;+}++int checkFieldsS2_1(S2_1* s1, S2_1* s2){+    int a = checkFieldsC13(&(s1->a),&(s2->a));+    int b = s1->b == s2->b;+    return a && b;+}++int checkFieldsS2_2(S2_2* s1, S2_2* s2){+    int a = checkFieldsC2(&(s1->a),&(s2->a));+    int b = checkFieldsC1(&(s1->b),&(s2->b));+    return a && b;+}++int checkFieldsS2_3(S2_3* s1, S2_3* s2){+    int a = checkFieldsC0(&(s1->a),&(s2->a));+    return a;+}++int checkFieldsS2(S2* s1, S2* s2){+    if (s1->tag != s2->tag) return 0;+    if (s1->tag == 0) return checkFieldsS2_1(&s1->val.a,&s2->val.a);+    if (s1->tag == 1) return checkFieldsS2_2(&s1->val.b,&s2->val.b);+    if (s1->tag == 2) return checkFieldsS2_3(&s1->val.c,&s2->val.c);+    return 0;+}++HsInt16 getSizeS2() {+    return sizeof(S2);+}++HsInt16 getAlignmentS2() {+    return alignof(S2);+}++typedef struct S3_1{+    S1 a;+} S3_1;++typedef struct S3_2{+    S2 a;+} S3_2;++typedef struct S3_3{+    HsInt8 a;+} S3_3;++typedef union S3_union{+    S3_1 a;+    S3_2 b;+    S3_3 c;+} S3_union;++typedef struct S3 {+    HsWord8 tag;+    S3_union val;+} S3;++S3 * newS3_1(S1* a){+    S3 * ret = (S3*) malloc(sizeof(S3));+    ret->tag = 0;+    ret->val.a.a = *a;+    return ret;+}++S3 * newS3_2(S2* a){+    S3 * ret = (S3*) malloc(sizeof(S3));+    ret->tag = 1;+    ret->val.b.a = *a;+    return ret;+}++S3 * newS3_3(HsInt8 a){+    S3 * ret = (S3*) malloc(sizeof(S3));+    ret->tag = 2;+    ret->val.c.a = a;+    return ret;+}++void pokeS3_1(S3* un, S1* a){+    un->tag = 0;+    un->val.a.a = *a;+}++void pokeS3_2(S3* un, S2* a){+    un->tag = 1;+    un->val.b.a = *a;+}++void pokeS3_3(S3* un, HsInt8 a){+    un->tag = 2;+    un->val.c.a = a;+}++int checkOffsetsS3_1(HsInt16 *offs){+    int a = offsetof(S3_1, a) == offs[0];+    return a;+}++int checkOffsetsS3_2(HsInt16 *offs){+    int a = offsetof(S3_2, a) == offs[0];+    return a;+}++int checkOffsetsS3_3(HsInt16 *offs){+    int a = offsetof(S3_3, a) == offs[0];+    return a;+}++int checkOffsetsS3(HsInt16 *offs){+    int t = offsetof(S3, tag) == offs[0];+    int v = offsetof(S3, val) == offs[1];+    return t && v;+}++int checkFieldsS3_1(S3_1* s1, S3_1* s2){+    int a = checkFieldsS1(&(s1->a),&(s2->a));+    return a;+}++int checkFieldsS3_2(S3_2* s1, S3_2* s2){+    int a = checkFieldsS2(&(s1->a),&(s2->a));+    return a;+}++int checkFieldsS3_3(S3_3* s1, S3_3* s2){+    int a = s1->a == s2->a;+    return a;+}++int checkFieldsS3(S3* s1, S3* s2){+    if (s1->tag != s2->tag) return 0;+    if (s1->tag == 0) return checkFieldsS3_1(&s1->val.a,&s2->val.a);+    if (s1->tag == 1) return checkFieldsS3_2(&s1->val.b,&s2->val.b);+    if (s1->tag == 2) return checkFieldsS3_3(&s1->val.c,&s2->val.c);+    return 0;+}++HsInt16 getSizeS3() {+    return sizeof(S3);+}++HsInt16 getAlignmentS3() {+    return alignof(S3);+}++typedef struct S4_1{+    C0 a;+} S4_1;++typedef struct S4_2{+    C0 a;+} S4_2;++typedef struct S4_3{+    C0 a;+} S4_3;++typedef struct S4_4{+    C1 a;+} S4_4;++typedef union S4_union{+    S4_1 a;+    S4_2 b;+    S4_3 c;+    S4_4 d;+} S4_union;++typedef struct S4 {+    HsWord8 tag;+    S4_union val;+} S4;++S4 * newS4_1(C0* a){+    S4 * ret = (S4*) malloc(sizeof(S4));+    ret->tag = 0;+    ret->val.a.a = *a;+    return ret;+}++S4 * newS4_2(C0* a){+    S4 * ret = (S4*) malloc(sizeof(S4));+    ret->tag = 1;+    ret->val.b.a = *a;+    return ret;+}++S4 * newS4_3(C0* a){+    S4 * ret = (S4*) malloc(sizeof(S4));+    ret->tag = 2;+    ret->val.c.a = *a;+    return ret;+}++S4 * newS4_4(C1* a){+    S4 * ret = (S4*) malloc(sizeof(S4));+    ret->tag = 3;+    ret->val.d.a = *a;+    return ret;+}++void pokeS4_1(S4* un, C0* a){+    un->tag = 0;+    un->val.a.a = *a;+}++void pokeS4_2(S4* un, C0* a){+    un->tag = 1;+    un->val.b.a = *a;+}++void pokeS4_3(S4* un, C0* a){+    un->tag = 2;+    un->val.c.a = *a;+}++void pokeS4_4(S4* un, C1* a){+    un->tag = 3;+    un->val.d.a = *a;+}++int checkOffsetsS4_1(HsInt16 *offs){+    int a = offsetof(S4_1, a) == offs[0];+    return a;+}++int checkOffsetsS4_2(HsInt16 *offs){+    int a = offsetof(S4_2, a) == offs[0];+    return a;+}++int checkOffsetsS4_3(HsInt16 *offs){+    int a = offsetof(S4_3, a) == offs[0];+    return a;+}++int checkOffsetsS4_4(HsInt16 *offs){+    int a = offsetof(S4_4, a) == offs[0];+    return a;+}++int checkOffsetsS4(HsInt16 *offs){+    int t = offsetof(S4, tag) == offs[0];+    int v = offsetof(S4, val) == offs[1];+    return t && v;+}++int checkFieldsS4_1(S4_1* s1, S4_1* s2){+    int a = checkFieldsC0(&(s1->a),&(s2->a));+    return a;+}++int checkFieldsS4_2(S4_2* s1, S4_2* s2){+    int a = checkFieldsC0(&(s1->a),&(s2->a));+    return a;+}++int checkFieldsS4_3(S4_3* s1, S4_3* s2){+    int a = checkFieldsC0(&(s1->a),&(s2->a));+    return a;+}++int checkFieldsS4_4(S4_4* s1, S4_4* s2){+    int a = checkFieldsC1(&(s1->a),&(s2->a));+    return a;+}++int checkFieldsS4(S4* s1, S4* s2){+    if (s1->tag != s2->tag) return 0;+    if (s1->tag == 0) return checkFieldsS4_1(&s1->val.a,&s2->val.a);+    if (s1->tag == 1) return checkFieldsS4_2(&s1->val.b,&s2->val.b);+    if (s1->tag == 2) return checkFieldsS4_3(&s1->val.c,&s2->val.c);+    if (s1->tag == 3) return checkFieldsS4_4(&s1->val.d,&s2->val.d);+    return 0;+}++HsInt16 getSizeS4() {+    return sizeof(S4);+}++HsInt16 getAlignmentS4() {+    return alignof(S4);+}+

@@ -1,239 +0,0 @@-{-#LANGUAGE GADTs         #-}-{-#LANGUAGE TypeOperators #-}-{-#LANGUAGE KindSignatures #-}-{-#LANGUAGE FlexibleInstances #-}-{-#LANGUAGE FlexibleContexts #-}-{-#LANGUAGE ScopedTypeVariables #-} -{-#LANGUAGE InstanceSigs #-}-{-#LANGUAGE PartialTypeSignatures #-}--{-#LANGUAGE DataKinds #-}-module GenericType (-    BasicType(..),-    GenericType(..),-    NestedType(..),-    NestedToType(..),-    ok_vector-    ) where--- Test modules-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Modifiers (NonEmptyList(..))--- Tested modules-import Foreign.Storable.Generic.Internal---- Test data-import Foreign.Storable.Generic.Tools-import Foreign.Storable.Generic.Instances-import Foreign.Ptr (Ptr, nullPtr, plusPtr)-import Foreign.C.Types-import Foreign.Storable-import GHC.Generics  -import Data.Int-import Data.Word-import Data.Bits-import Data.Proxy-import Debug.Trace-import GHC.TypeLits--import Unsafe.Coerce---- | TestType - the basic building blocks from which--- GStorable instances are built.-class (Arbitrary a,Eq a,GStorable a, Show a) => TestType a---- Generating random pointers.-instance Arbitrary (Ptr a) where-    arbitrary = do-        plus <- choose (0, 10000)-        return $ plusPtr nullPtr plus--instance TestType Int-instance TestType Int8-instance TestType Int16-instance TestType Int32-instance TestType Int64--instance TestType Word-instance TestType Word8-instance TestType Word16-instance TestType Word32-instance TestType Word64--instance TestType Double-instance TestType Float-instance TestType (Ptr a)-instance TestType Char--instance TestType CFloat--instance TestType CDouble---- | The wrappable type class. Wraps the type in generics--- and then into GenericType data type.-class (Show a) => Wrappable a where-    wrapType :: a -> GenericType------------------------- | Contains the basic building blocks that generate GStorable type classes.-data BasicType where-   BasicType :: (TestType a) => a -> BasicType--instance Show BasicType where-    show (BasicType val) = show val--instance Arbitrary BasicType where-    arbitrary = do-        valInt     <- arbitrary  :: Gen Int -        valInt8    <- arbitrary  :: Gen Int8-        valInt16   <- arbitrary  :: Gen Int16 -        valInt32   <- arbitrary  :: Gen Int32 -        valInt64   <- arbitrary  :: Gen Int64-        valWord     <- arbitrary :: Gen Word -        valWord8    <- arbitrary :: Gen Word8-        valWord16   <- arbitrary :: Gen Word16 -        valWord32   <- arbitrary :: Gen Word32 -        valWord64   <- arbitrary :: Gen Word64-        valDouble  <- arbitrary  :: Gen Double-        valFloat   <- arbitrary  :: Gen Float-        valPtr     <- arbitrary  :: Gen (Ptr a)-        valChar    <- arbitrary  :: Gen Char--        valCDouble  <- arbitrary :: Gen CDouble-        valCFloat   <- arbitrary :: Gen CFloat--        elements [BasicType valInt,    BasicType valInt8, BasicType valInt16-                 ,BasicType valInt32 , BasicType valInt64, BasicType valCDouble-                 ,BasicType valCFloat, BasicType valPtr, BasicType valChar-                 ,BasicType valWord,   BasicType valWord8, BasicType valWord16-                 ,BasicType valWord32, BasicType valWord64]---- | Wraps the basic type with 'M1' and 'K1' type constructors. --- The result is usable by the testing algorithms.-instance Wrappable BasicType where-    wrapType (BasicType val) = GenericType $ M1 $ K1 val---- Some tricks for generics:-instance Arbitrary c     => Arbitrary (K1 i c p) where-    arbitrary = K1 <$> arbitrary-instance Arbitrary (f p) => Arbitrary (M1 i c f p) where-    arbitrary = M1 <$> arbitrary-instance (Arbitrary (f p), Arbitrary (g p)) => Arbitrary ((:*:) f g p) where-    arbitrary = (:*:) <$> (arbitrary :: Gen (f p)) <*> (arbitrary :: Gen (g p))----- | Used withing GenericType to enforce that the types can be joined with :*:.-data MyPhantom---- | Constains generic representations of arbitrary data-types.--- The Show constraint is used so we can print out the badly working cases.--- The Eq and Arbitrary one are for generating different values for the same types.-data GenericType where-   GenericType  :: (p ~ MyPhantom, Eq (f p), Arbitrary (f p), GStorable' f, Show (f p)) => f p -> GenericType--instance Arbitrary GenericType where-    arbitrary = do-        n <- choose (0,100) :: Gen Int-        genType n---- | Generates a random generic representation.--- Does not resemble the generic representation from real types.-genType :: Int  -- ^ Number of randomness. -        -> Gen GenericType-genType 0 = wrapType <$> (arbitrary :: Gen BasicType)-genType n = do-    -- Choose what kind of element this layer is.-    step <- arbitrary :: Gen GenTree-    case step of-        -- A product - a tree-        Producted -> do-            -- Generate two subtrees with the same function-            div <- choose  (0,n) -            gt1 <- genType  div-            gt2 <- genType (n-div)-            return $ (\(GenericType t1) (GenericType t2) -> GenericType $ t1 :*: t2) gt1 gt2 -        -- Wrap in meta-data anything that's generated later-        M1ed      -> (\(GenericType t) -> GenericType $ M1 t) <$> genType (n-1) -        -- Wrap in K1 anything that's generated later.-        K1ed      -> (\(GenericType t) -> GenericType $ K1 t) <$> genType (n-1) ---- | Enums for generating the generic representations.-data GenTree = Producted | M1ed | K1ed--instance Arbitrary GenTree where-    arbitrary = elements [Producted, M1ed , K1ed]---- | Show the generic metadata. Could use some pretty printing later. -instance Show GenericType where-    show (GenericType    val) = show val---- | Wrap the generic representation as it were derived from a proper type.-instance Wrappable GenericType where-    wrapType    (GenericType  val) = GenericType $ M1 $ K1 $ val---- | Wrapper for creating nested types.-data NestedType (n :: Nat) = NestedType GenericType--instance (KnownNat n) => Show (NestedType n) where-    show (NestedType (GenericType val)) = type_info ++ show val-        where type_info = "NestedType " ++ (show $ natVal (Proxy :: Proxy n)) ++ " "--instance (KnownNat n) => Arbitrary (NestedType n) where-    arbitrary = NestedType <$> nestedType (fromIntegral $ natVal (Proxy :: Proxy n))---- | Wrapper for creating nested types up to a certain level.-data NestedToType (n :: Nat) = NestedToType GenericType--instance (KnownNat n) => Show (NestedToType n) where-    show (NestedToType (GenericType val)) = type_info ++ show val-        where type_info = "NestedToType " ++ (show $ natVal (Proxy :: Proxy n)) ++ " "--instance (KnownNat n) => Arbitrary (NestedToType n) where-    arbitrary = NestedToType <$> nestedToType (fromIntegral $ natVal (Proxy :: Proxy n))---- | Generate a nested type.-nestedType :: Int             -- ^ Depth of the generated type. -           -> Gen GenericType -- ^ Resulting generator.-nestedType n  = nestedType' n gen-    where gen = wrapType <$> (arbitrary :: Gen BasicType) --nestedType' :: Int             -- ^ Depth of the generated type.-            -> Gen GenericType -- ^ Accumulator-            -> Gen GenericType -- ^ Resulting generator-nestedType' n gen -    | n <  0 = error "GenericType.nestedType': n is less than 0"-    | n == 0 = gen-    | n > 0  = do -        fields <- choose (1, 4*n)-        nestedType' (n-1) (wrapType <$> toGenericType <$> vectorOf fields gen) ---- | For generating nested types with components from levels below.-nestedToType :: Int -> Gen (GenericType)-nestedToType n =do-    sublist <- suchThat (sublistOf [0..n]) (\x -> length x > 0)-    wrapType <$> toGenericType <$> mapM nestedType sublist---- | Uses the :*: operator to construct a representation of a product type.-typeProduct :: GenericType -> GenericType -> GenericType-typeProduct (GenericType val1) (GenericType val2) = GenericType $ val1 :*: val2---- | Creates a tree for type product.-toGenericType :: [GenericType] -> GenericType-toGenericType []  = error "toGenericType requires at least one type"-toGenericType [v] = v-toGenericType types = foldl1 typeProduct types---- | Simulates the K1 step for generic representations. -instance {-#OVERLAPS#-} (GStorable' f) => GStorable' (K1 i (f p)) where-    glistSizeOf'    _ = [internalSizeOf (undefined :: f p)]-    glistAlignment' _ = [internalAlignment (undefined :: f p)]-    gpeekByteOff' offs n ptr off   = K1 <$> internalPeekByteOff ptr (off + f_off)-        where f_off = offs !! n-    gpokeByteOff' offs n ptr off (K1 v) = internalPokeByteOff ptr (off + f_off) v-        where f_off = offs !! n-    gnumberOf'      _  = 1---- | Helps with avoiding NaN problem. -ok_vector :: Int -> Gen [Word8]-ok_vector n = vectorOf n (suchThat arbitrary $ (\x-> (x .&. 127) /= 127) )-

@@ -1,218 +0,0 @@-{-#LANGUAGE ScopedTypeVariables #-}-{-#LANGUAGE DeriveGeneric       #-}-{-#LANGUAGE DataKinds           #-}-{-#LANGUAGE GADTs               #-}-module Foreign.Storable.Generic.Internal.GStorable'Spec where----- Test tools-import Test.Hspec-import Test.QuickCheck-import GenericType ---- Tested modules-import Foreign.Storable.Generic.Internal ---- Additional data-import Foreign.Storable.Generic.Instances-import GHC.Generics-import Foreign.Marshal.Alloc (malloc, mallocBytes, free)-import Foreign.Marshal.Array (peekArray, pokeArray)-import Data.Int-import Data.Word----spec :: Spec-spec = do -    describe "glistSizeOf'" $ do-        it "instance M1    is equal to: glistSizeOf' a" $ do-            property (\(GenericType val) -> do-                glistSizeOf' (M1 $ val) `shouldBe` glistSizeOf' val -                )-        it "instance K1    is equal to: [internalSizeOf a]" $ do-            property (\(GenericType val) -> do-                glistSizeOf' (K1 $ val) `shouldBe` [internalSizeOf val] -                )-        it "instance (:*:) is equal to: glistSizeOf' a ++ glistSizeOf' b" $ do-            property (\(GenericType val1) (GenericType val2) -> do -                glistSizeOf' (val1 :*: val2 ) `shouldBe` (glistSizeOf' val1 ++ glistSizeOf' val2) -                )-    describe "glistAlignment'" $ do-        it "instance M1    is equal to: glistAlignment' a" $ do-            property (\(GenericType val) -> do-                glistAlignment' (M1 $ val) `shouldBe` glistAlignment' val -                )-        it "instance K1    is equal to: [internalAlignment a]" $ do-            property (\(GenericType val) -> do-                glistAlignment' (K1 $ val) `shouldBe` [internalAlignment val] -                )-        it "instance (:*:) is equal to: glistAlignment' a ++ glistAlignment' b" $ do-            property (\(GenericType val1) (GenericType val2) -> do -                glistAlignment' (val1 :*: val2 ) `shouldBe` (glistAlignment' val1 ++ glistAlignment' val2) -                )-    describe "gnumberOf' " $ do-        it "instance M1    is equal to: gnumberOf' a" $ do-            property (\(GenericType val) -> do-                gnumberOf' (M1 $ val) `shouldBe` gnumberOf' val -                )-        it "instance K1    is equal to: 1" $ do-            property (\(GenericType val) -> do-                gnumberOf' (K1 $ val) `shouldBe` 1-                )-        it "instance (:*:) is equal to: gnumberOf' a + gnumberOf' b" $ do-            property (\(GenericType val1) (GenericType val2) -> do -                gnumberOf' (val1 :*: val2 ) `shouldBe` (gnumberOf' val1 + gnumberOf' val2) -                )-    describe "gpeekByteOff' " $ do-        it "instance M1    is equal to: M1 <$> gpeekByteOff' offs ix ptr off" $ do-            property (\(GenericType (val :: f p)) -> do                -                let size      = internalSizeOf  val-                    offs      = internalOffsets val-                    no_fields = gnumberOf' (undefined :: f p)-                -- Random global offset-                off   <- generate $ suchThat arbitrary (\x -> x>=0 && x < 100)--                -- Reserve some memory and write some data to it.-                ptr    <- mallocBytes (off + size)-                values <- generate $ ok_vector (off + size) :: IO [Word8]-                pokeArray ptr values--                -- Check:-                -- With M1-                v1 <- gpeekByteOff' offs (no_fields - 1) ptr off     :: IO (M1 i c f p)-                -- Without M1-                v2 <- gpeekByteOff' offs (no_fields - 1) ptr off     :: IO (f p)-                free ptr--                v1 `shouldBe` M1 v2-                )-        it "instance K1    is equal to: K1 <$> internalPeekByteOff ptr (f_off + off) val" $ do-            property (\(GenericType (val :: f p)) -> do-                let size = internalSizeOf val-                -- Random global offsets and field offset-                f_off <- generate $ suchThat arbitrary (>=0) -                off   <- generate $ suchThat arbitrary (>=0)--                -- Reserve some memory and write some data to it.-                ptr    <- mallocBytes (f_off + off + size)-                values <- generate $ ok_vector (f_off + off + size) :: IO [Word8]-                pokeArray ptr values-               -                -- Check:-                -- With K1-                v1 <- gpeekByteOff' [f_off] 0 ptr off     :: IO (K1 i (f p) p)-                -- Without K1-                v2 <- internalPeekByteOff ptr (f_off + off) :: IO (f p)-                free ptr--                v1 `shouldBe` K1 v2--                )-        it "instance (:*:) is equal to: (:*:) <$> peeker (ix - n2) <*> peeker ix  \n\-            \                                where peeker n_ix   = gpeekByteOff' offsets n_ix ptr off \n" $ do-            property (\(GenericType (val1 :: f p)) (GenericType (val2 :: g p)) -> do                -                let offsets   = internalOffsets (undefined :: (:*:) f g p)-                    size      = internalSizeOf (undefined :: (:*:) f g p)-                    no_fields = gnumberOf' (undefined :: (:*:) f g p)-                    n2        = gnumberOf' (undefined :: g p)---                -- Random global offset-                off   <- generate $ suchThat arbitrary (>=0)--                -- Reserve some memory and write some data to it.-                ptr    <- mallocBytes (off + size)-                values <- generate $ ok_vector (off + size) :: IO [Word8]-                pokeArray ptr values--                -- Check:-                -- Left side-                v1   <- gpeekByteOff' offsets (no_fields - 1)      ptr off :: IO ((:*:) f g p)-                -- Right side-                v2_a <- gpeekByteOff' offsets (no_fields - 1 - n2) ptr off :: IO (f p)-                v2_b <- gpeekByteOff' offsets (no_fields - 1)      ptr off :: IO (g p)-                free ptr--                v1 `shouldBe` (v2_a :*: v2_b)-                )-    describe "gpokeByteOff' " $ do-        it "instance M1    is equal to: gpokeByteOff' offs ix ptr off val" $ do-            property (\(GenericType (val :: f p)) -> do-                let size    = internalSizeOf val-                    offsets = internalOffsets val -                    no_fields= gnumberOf' (undefined :: f p)-                -- Get the offsets to test-                off   <- generate $ suchThat arbitrary (>=0)--                -- Reserve some memory to read from-                ptr    <- mallocBytes (off + size)-                -                -- First test-                -- With M1-                gpokeByteOff' offsets (no_fields - 1) ptr off (M1 val)-                bytes1 <- peekArray (off + size) ptr :: IO [Word8]-              -                -- Second test-                -- Without M1-                gpokeByteOff' offsets (no_fields - 1) ptr off val-                bytes2 <- peekArray (off + size) ptr :: IO [Word8]-         -                free ptr-                -- Check:-                bytes1 `shouldBe` bytes2-                )-        it "instance K1    is equal to: internalPokeByteOff ptr (f_off + off) val" $ do-            property (\(GenericType (val :: f p)) -> do-                let size = internalSizeOf val-                -- Get the offsets to test-                f_off <- generate $ suchThat arbitrary (>=0) -                off   <- generate $ suchThat arbitrary (>=0)--                -- Reserve some memory to read from-                ptr    <- mallocBytes (f_off + off + size)-                -                -- First test-                -- With K1-                gpokeByteOff' [f_off] 0 ptr off (K1 val)-                bytes1 <- peekArray (f_off + off + size) ptr :: IO [Word8]-              -                -- Second test-                -- Without K1-                internalPokeByteOff ptr (f_off + off) val-                bytes2 <- peekArray (f_off + off + size) ptr :: IO [Word8]-         -                free ptr-                -- Check:-                bytes1 `shouldBe` bytes2-                )-        it "instance (:*:) is equal to: (:*:) <$> poker (ix - n2) a <*> poker ix b \n\-            \                                where poker n_ix v  = gpokeByteOff' offsets n_ix ptr off v" $ do-            property (\(GenericType (val1 :: f p)) (GenericType (val2 :: g p)) -> do-                let offsets   = internalOffsets (undefined :: (:*:) f g p)-                    no_fields = gnumberOf'      (undefined :: (:*:) f g p)-                    n2        = gnumberOf'      (undefined :: g p        )-                    size      = internalSizeOf  (undefined :: (:*:) f g p)-                -                -- Get the offset to test-                off   <- generate $ suchThat arbitrary (>=0)--                -- Reserve some memory to read from-                ptr    <- mallocBytes (off + size)-                -                -- First poke-                -- Left part of the tree-                gpokeByteOff' offsets (no_fields - 1) ptr off (val1 :*: val2)-                bytes1 <- peekArray (off + size) ptr :: IO [Word8]-              -                -- Second pokes-                -- Right part of the tree-                gpokeByteOff' offsets (no_fields - 1 - n2) ptr off val1-                gpokeByteOff' offsets (no_fields -1)       ptr off val2-                -                bytes2 <- peekArray (off + size) ptr :: IO [Word8]-         -                free ptr-                -- Check:-                bytes1 `shouldBe` bytes2-                )

@@ -1,130 +0,0 @@-{-#LANGUAGE ScopedTypeVariables #-}-{-#LANGUAGe DataKinds           #-}-{-#LANGUAGE DeriveGeneric       #-}-{-#LANGUAGE DeriveAnyClass      #-}-{-#LANGUAGE FlexibleContexts    #-}-module Foreign.Storable.Generic.Internal.GStorableSpec where---- Test tools-import Test.Hspec-import Test.QuickCheck--import GenericType ---- Tested modules-import Foreign.Storable.Generic.Internal ---- Additional data-import Foreign.Storable.Generic -- overlapping Storable-import Foreign.Storable.Generic.Instances-import Data.Int-import Data.Word-import GHC.Generics-import Foreign.Ptr (Ptr, plusPtr)-import Foreign.Marshal.Alloc (malloc, mallocBytes, free)-import Foreign.Marshal.Array (peekArray,pokeArray)--data TestData  = TestData Int Int64 Int8 Int8-    deriving (Show, Generic, GStorable, Eq)-instance Arbitrary TestData where-    arbitrary = TestData <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary---data TestData2 = TestData2 Int8 TestData Int32 Int64-    deriving (Show, Generic, GStorable, Eq)-instance Arbitrary TestData2 where-    arbitrary = TestData2 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary--data TestData3 = TestData3 Int64 TestData2 Int16 TestData Int8-    deriving (Show, Generic, GStorable, Eq)-instance Arbitrary TestData3 where-    arbitrary = TestData3 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary---sizeEquality a = do-    gsizeOf a `shouldBe` internalSizeOf (from a)--alignmentEquality a = do-    gsizeOf a `shouldBe` internalSizeOf (from a)--pokeEquality a = do-    let size = gsizeOf a-    off <- generate $ suchThat arbitrary (>=0)--    ptr <- mallocBytes (off + size)-    -- First poke-    gpokeByteOff ptr off a-    bytes1 <- peekArray (off+size) ptr :: IO [Word8]--    internalPokeByteOff ptr off (from a)-    bytes2 <- peekArray (off+size) ptr :: IO [Word8]--    free ptr-    bytes1 `shouldBe` bytes2            --peekEquality (a :: t) = do-    let size = gsizeOf a-    off   <- generate $ suchThat arbitrary (>=0)-    ptr   <- mallocBytes (off + size)-    bytes <- generate $ ok_vector (off+size) :: IO [Word8]-   -    -- Save random stuff to memory-    pokeArray ptr bytes-   -    -- Take a peek-    v1 <- gpeekByteOff        ptr off :: IO t-    v2 <- internalPeekByteOff ptr off :: IO (Rep t p)--    free ptr-    -    v1 `shouldBe` to v2           ---peekAndPoke (a :: t)= do-    ptr   <- malloc :: IO (Ptr t)-    gpokeByteOff ptr 0 a-    (gpeekByteOff ptr 0) `shouldReturn` a---spec :: Spec-spec = do-    describe "gsizeOf" $ do-        it "is equal to: internalSizeOf (from a)" $ property $ do -            test1 <- generate $ arbitrary :: IO TestData-            test2 <- generate $ arbitrary :: IO TestData2-            test3 <- generate $ arbitrary :: IO TestData3-            sizeEquality test1-            sizeEquality test2-            sizeEquality test3-    describe "galignment" $ do-        it "is equal to: internalAlignment (from a)" $ property $ do -            test1 <- generate $ arbitrary :: IO TestData-            test2 <- generate $ arbitrary :: IO TestData2-            test3 <- generate $ arbitrary :: IO TestData3-            alignmentEquality test1-            alignmentEquality test2-            alignmentEquality test3-    describe "gpokeByteOff" $ do-        it "is equal to: internalPokeByteOff ptr off (from a)" $ property $ do -            test1 <- generate $ arbitrary :: IO TestData-            test2 <- generate $ arbitrary :: IO TestData2-            test3 <- generate $ arbitrary :: IO TestData3-            pokeEquality test1-            pokeEquality test2-            pokeEquality test3-    describe "gpeekByteOff" $ do-        it "is equal to: to <$> internalPeekByteOff ptr off" $ property $ do -            test1 <- generate $ arbitrary :: IO TestData-            test2 <- generate $ arbitrary :: IO TestData2-            test3 <- generate $ arbitrary :: IO TestData3-            peekEquality test1-            peekEquality test2-            peekEquality test3-    describe "Other tests:" $ do-        it "gpokeByteOff ptr 0 val >> gpeekByteOff ptr 0 == val" $ property $ do        -            test1 <- generate $ arbitrary :: IO TestData-            test2 <- generate $ arbitrary :: IO TestData2-            test3 <- generate $ arbitrary :: IO TestData3-            peekAndPoke test1-            peekAndPoke test2-            peekAndPoke test3 

@@ -1,158 +0,0 @@-{-#LANGUAGE ScopedTypeVariables #-}-{-#LANGUAGE DeriveGeneric       #-}-{-#LANGUAGE DataKinds           #-}-{-#LANGUAGE GADTs               #-}-module Foreign.Storable.Generic.InternalSpec where----- Test tools-import Test.Hspec-import Test.QuickCheck-import GenericType ---- Tested modules-import Foreign.Storable.Generic.Internal ---- Additional data-import Foreign.Storable.Generic.Tools-import Foreign.Storable.Generic.Instances-import GHC.Generics-import Foreign.Marshal.Alloc (malloc, mallocBytes, free)-import Foreign.Marshal.Array (peekArray, pokeArray)-import Foreign.Ptr (Ptr, plusPtr)-import Data.Word----spec :: Spec-spec = do -    describe "internalSizeOf" $ do-        it "is equal to: calcSize $ zip (glistSizeOf' a) (glistAlignment' a)" $ do-            property (\((NestedToType (GenericType val)) :: NestedToType 4) -> -                internalSizeOf val `shouldBe` (calcSize $ zip (glistSizeOf' val) (glistAlignment' val) ) )-    describe "internalAlignment" $ do-        it "is equal to: maximum (glistAlignment' a)" $ do-            property (\((NestedToType (GenericType val)) :: NestedToType 4) -> -                internalAlignment val `shouldBe` (maximum $ glistAlignment' val) )-    describe "internalOffsets" $ do-        it "is equal to: calcOffsets $ zip (glistSizeOf' a) (glistAlignment' a)" $ do-            property (\((NestedToType (GenericType val)) :: NestedToType 4) -> -                internalOffsets val `shouldBe` (calcOffsets $ zip (glistSizeOf' val) (glistAlignment' val) ) )-    describe "internalPeekByteOff" $ do-        it "is equal to: gpeekByteOff' (internalOffsets a) ptr off" $ do-            property (\((NestedToType (GenericType (val :: f p))) :: NestedToType 4) -> do-                let size      = internalSizeOf val-                    no_fields = gnumberOf' (undefined :: f p)-                off <- generate $ suchThat arbitrary (\x -> x>=0 && x < 100)-                -                -- Area in memory to peek-                bytes <- generate $ ok_vector (off + size)-                ptr <- mallocBytes (off + size)-                pokeArray ptr bytes-                -                -- first peek-                v1 <- internalPeekByteOff ptr off :: IO (f p)-                v2 <- gpeekByteOff' (internalOffsets val) (no_fields - 1) ptr off :: IO (f p)-                -                free ptr-                v1 `shouldBe` v2-                )-        it "it reads only specified area of the memory" $ do-            property $ (\((NestedToType (GenericType (test_type1 :: f p))) :: NestedToType 4) -> do    -                let size      = internalSizeOf test_type1 -                    pokeBytes = pokeArray :: (Ptr Word8 -> [Word8] -> IO ())-                -- The memory area-                ptr <- mallocBytes (size+16)-                -                -- Beginning state.-                bytes1_beginning <- generate $ ok_vector 8-                bytes1_middle    <- generate $ ok_vector size-                bytes1_end       <- generate $ ok_vector 8-                -                pokeBytes  ptr                   bytes1_beginning-                pokeBytes (plusPtr ptr 8)        bytes1_middle-                pokeBytes (plusPtr ptr (size+8)) bytes1_end-            -                v1 <- internalPeekByteOff ptr 8 :: IO (f p)-                -                -- Changed state -                bytes2_beginning <- generate $ suchThat (ok_vector 8) (/=bytes1_beginning)-                bytes2_end       <- generate $ suchThat (ok_vector 8) (/=bytes1_end)-                -                pokeBytes  ptr               bytes2_beginning-                pokeBytes (plusPtr ptr (size + 8)) bytes2_end-                -                v2 <- internalPeekByteOff ptr 8 :: IO (f p) - -                v1 `shouldBe` v2-                )-    describe "internalPokeByteOff" $ do-        it "is equal to: gpokeByteOff' (internalOffsets a) ptr off v" $ do-            property (\((NestedToType (GenericType (val :: f p))) :: NestedToType 4)  -> do-                let size = internalSizeOf val-                    no_fields = gnumberOf' (undefined :: f p)-                off <- generate $ suchThat arbitrary (\x -> x>=0 && x < 100)-                -                -- Area in memory to poke-                ptr <- mallocBytes (off + size)-                -                -- first poke-                internalPokeByteOff ptr off val-                bytes1 <- peekArray (off + size) ptr :: IO [Word8]-                -                -- second poke-                gpokeByteOff' (internalOffsets val) (no_fields - 1) ptr off val-                bytes2 <- peekArray (off + size) ptr :: IO [Word8]- -                free ptr-                -                bytes1 `shouldBe` bytes2-                )-        it "it modifies only specified area of the memory" $ do-            property $ (\((NestedToType (GenericType test_type1)) ::NestedToType 4)-> do    -                test_type2 <- generate $ suchThat arbitrary (/=test_type1)-                -- if test_type1 is different from test_type2, then -                -- the memory state has to change when poking both of them-                let size = internalSizeOf test_type1 -                    peekBytes = peekArray :: (Int -> Ptr Word8 -> IO [Word8])-                -- The memory area-                ptr <- mallocBytes (size+16)-               -                -- Beginning state.-                mem_state1_beginning <- peekBytes 8     ptr                   -                mem_state1_middle    <- peekBytes size (plusPtr ptr 8)              -                mem_state1_end       <- peekBytes 8    (plusPtr ptr (size+8))-            -                internalPokeByteOff ptr 8 test_type1-                -- Poked first variable-                mem_state2_beginning <- peekBytes 8     ptr-                mem_state2_middle    <- peekBytes size (plusPtr ptr 8)-                mem_state2_end       <- peekBytes 8    (plusPtr ptr (size+8))-            -                internalPokeByteOff ptr 8 test_type2-                -- Poked second state-                mem_state3_beginning <- peekBytes 8     ptr-                mem_state3_middle    <- peekBytes size (plusPtr ptr 8)-                mem_state3_end       <- peekBytes 8    (plusPtr ptr (size+8))-                -  -                -- Beginnings and ends should stay the same. The middle one should be different from-                -- the one at the beginning.-                sequence_ [mem_state1_beginning `shouldBe` mem_state2_beginning-                          ,mem_state2_beginning `shouldBe` mem_state3_beginning-                          ,mem_state1_end       `shouldBe` mem_state2_end                  -                          ,mem_state2_end       `shouldBe` mem_state3_end-                          ,(mem_state1_middle /= mem_state2_middle) || (mem_state1_middle /= mem_state3_middle) `shouldBe` True]-                )-    describe "other" $ do-        it "poke, then peek: receive the poked value" $ do-            property $ (\((NestedToType (GenericType (val :: f p) )) :: NestedToType 4) -> do-                let size = internalSizeOf val-                off <- generate $ suchThat arbitrary (\x -> x>=0 && x < 100)-                -                ptr <- mallocBytes (size + off)--                internalPokeByteOff ptr off val-                p_val <- internalPeekByteOff ptr off :: IO (f p) -                val `shouldBe` p_val-                ) 

@@ -1,29 +0,0 @@-module Foreign.Storable.Generic.ToolsSpec where----Tested modules-import Foreign.Storable.Generic.Tools--import Test.Hspec-import Test.QuickCheck--spec :: Spec -spec = do -    describe "getFilling" $ do-        it "getFilling [(2,2),(4,4),(1,1),(2,2)] == [Size 2, Padding 2, Size 4, Size 1, Padding 1, Size 2]" $ do-            getFilling [(2,2),(4,4),(1,1),(2,2)] `shouldBe` [Size 2, Padding 2, Size 4, Size 1, Padding 1, Size 2]-        it "getFilling [] = []" $ do-            getFilling [] `shouldBe` []-    describe "calcSize" $ do-        it "calcSize [] = 0" $ do-            calcSize [] `shouldBe` 0-        it "is equal to sum of padding" $ do-            let summer (Padding a) = a-                summer (Size    a) = a-            property $ do-                ls <- generate $ listOf $ suchThat arbitrary (\(a,b) -> a > 0 && b > 0)-                calcSize ls `shouldBe` (sum $ map summer $ getFilling ls)-    describe "calcOffsets" $ do-        it "calcOffsets [(2,2),(4,4),(1,1),(2,2)] == [0,4,8,10]" $ do-            calcOffsets [(2,2),(4,4),(1,1),(2,2)] `shouldBe` [0,4,8,10]-        it "calcOffsets [] = []" $ do-            calcOffsets [] `shouldBe` []

@@ -1,13 +0,0 @@-import Test.Hspec--import qualified Foreign.Storable.Generic.InternalSpec            as I-import qualified Foreign.Storable.Generic.ToolsSpec               as T-import qualified Foreign.Storable.Generic.Internal.GStorable'Spec as GS1-import qualified Foreign.Storable.Generic.Internal.GStorableSpec  as GS2----main :: IO ()-main = hspec (I.spec >> T.spec >> GS1.spec >> GS2.spec)--