derive-storable 0.1.0.6 → 0.1.1.0

raw patch · 9 files changed

+1324/−10 lines, 9 filesdep −derive-storabledep ~QuickCheckdep ~basedep ~hspecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: derive-storable

Dependency ranges changed: QuickCheck, base, hspec

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−1
• derive-storable.cabal +24/−8
• test/Basic/MemoryCSpec.hs +1/−1
• test/Basic/TestCases.hs +520/−0
• test/GenericRep/GenericType.hs +239/−0
• test/Spec/Foreign/Storable/Generic/Internal/GStorable'Spec.hs +218/−0
• test/Spec/Foreign/Storable/Generic/Internal/GStorableSpec.hs +130/−0
• test/Spec/Foreign/Storable/Generic/InternalSpec.hs +158/−0
• test/Spec/Foreign/Storable/Generic/ToolsSpec.hs +29/−0

@@ -1,6 +1,10 @@ # Revision history for derive-storable -## 0.1.0.5  -- 2016-12-07+## 0.1.1.0  -- 2017-07-19++* Bumped to GHC 8.2.*++## 0.1.0.6  -- 2016-12-07  * Made the information about performance problems more visible in README.md 

@@ -1,6 +1,6 @@ name:                derive-storable -version:             0.1.0.6+version:             0.1.1.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,12 +20,12 @@ extra-source-files:  ChangeLog.md README.md  cabal-version:       >=1.10-+tested-with:         GHC==7.10.3, GHC==8.0.1, GHC==8.0.2, GHC==8.2.1  library   exposed-modules:     Foreign.Storable.Generic, Foreign.Storable.Generic.Tools                      , Foreign.Storable.Generic.Internal, Foreign.Storable.Generic.Instances       -  build-depends:       base >=4.8 && <4.10+  build-depends:       base >=4.8 && < 4.11   hs-source-dirs:      src   default-language:    Haskell2010  @@ -36,15 +36,31 @@   hs-source-dirs:      src, test/Basic, test/Basic/cbits   c-sources:           test/Basic/cbits/TestCases.c    main-is:             MemoryCSpec.hs-  build-depends:       base >= 4.8 && <4.10, hspec == 2.2.* ,QuickCheck == 2.8.*, derive-storable+  other-modules:       Foreign.Storable.Generic+                     , Foreign.Storable.Generic.Instances+                     , Foreign.Storable.Generic.Internal+                     , Foreign.Storable.Generic.Tools+                     , TestCases    +  build-depends:       base >= 4.8 && < 4.11, 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-  build-depends:       base >= 4.8 && < 4.10, derive-storable, hspec == 2.2.*, QuickCheck == 2.8.*+  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 && < 4.11, hspec == 2.4.*, QuickCheck >= 2.10    default-language:    Haskell2010 

@@ -8,7 +8,7 @@  -- Test libraries import Test.Hspec-import Test.QuickCheck+import Test.QuickCheck hiding (getSize)  -- Helpers import Foreign.Marshal.Array

@@ -0,0 +1,520 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TestCases where++import GHC.Generics (Generic, Rep, from)+import Foreign.C.Types+import Foreign.Storable+import Foreign.Storable.Generic+import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr)+import Foreign.Marshal.Alloc (malloc, free)+import Foreign.Marshal.Array (mallocArray, pokeArray)++import Foreign.Storable.Generic.Tools+import Foreign.Storable.Generic.Internal+import Foreign.Storable.Generic.Instances+import Data.Int+import Control.Monad (sequence, liftM)+import System.Exit++import Test.QuickCheck+-- The module tests the memory alignment of Storable data-types +-- derived with generic-storable package. ++-- Adding parametric polimorphism to reduce the boilerplate.+class (Storable a) => Checkable a where+  -- | Checks whether the fields are the same+  checkFields  :: Ptr a -> Ptr a -> IO Bool +  -- | Checks whether the offsets are the same+  checkOffsets :: a -> Ptr Int16 -> IO Bool +  -- | Checks whether the size is the same+  getSize    :: a -> IO Int              +  -- | Checks whether the alignment is the same+  getAlignment :: a-> IO Int              +  +  new          :: a -> IO (Ptr a)+++newStorable :: Storable a => a -> IO (Ptr a)+newStorable val = do+  ptr <- malloc+  poke ptr val+  return ptr++goffsets :: (GStorable' (Rep a), GStorable a, Generic a) => a -> [Int16]+goffsets v = map fromIntegral $ internalOffsets (from v)++data C1 = C1 Int32 Int32+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C1 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC1 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC1 offs+    getSize        a          = fromIntegral <$> getSizeC1+    getAlignment   a          = fromIntegral <$> getAlignmentC1+    new (C1 a b) = do+        ptr <- newC1 a b+        return ptr++instance Arbitrary C1 where +    arbitrary = C1 <$> arbitrary <*> arbitrary++foreign import ccall newC1 :: Int32 -> Int32 -> IO (Ptr C1)+foreign import ccall checkFieldsC1 :: Ptr C1 -> Ptr C1 -> IO Int8+foreign import ccall checkOffsetsC1 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC1 :: IO Int16+foreign import ccall getAlignmentC1 :: IO Int16++data C2 = C2 Int32 Int16 Int8+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C2 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC2 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC2 offs+    getSize        a          = fromIntegral <$> getSizeC2+    getAlignment   a          = fromIntegral <$> getAlignmentC2+    new (C2 a b c) = do+        ptr <- newC2 a b c+        return ptr++instance Arbitrary C2 where +    arbitrary = C2 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC2 :: Int32 -> Int16 -> Int8 -> IO (Ptr C2)+foreign import ccall checkFieldsC2 :: Ptr C2 -> Ptr C2 -> IO Int8+foreign import ccall checkOffsetsC2 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC2 :: IO Int16+foreign import ccall getAlignmentC2 :: IO Int16++data C3 = C3 Int32 Int8 Int16+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C3 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC3 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC3 offs+    getSize        a          = fromIntegral <$> getSizeC3+    getAlignment   a          = fromIntegral <$> getAlignmentC3+    new (C3 a b c) = do+        ptr <- newC3 a b c+        return ptr++instance Arbitrary C3 where +    arbitrary = C3 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC3 :: Int32 -> Int8 -> Int16 -> IO (Ptr C3)+foreign import ccall checkFieldsC3 :: Ptr C3 -> Ptr C3 -> IO Int8+foreign import ccall checkOffsetsC3 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC3 :: IO Int16+foreign import ccall getAlignmentC3 :: IO Int16++data C4 = C4 Int32 Int8 Int8+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C4 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC4 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC4 offs+    getSize        a          = fromIntegral <$> getSizeC4+    getAlignment   a          = fromIntegral <$> getAlignmentC4+    new (C4 a b c) = do+        ptr <- newC4 a b c+        return ptr++instance Arbitrary C4 where +    arbitrary = C4 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC4 :: Int32 -> Int8 -> Int8 -> IO (Ptr C4)+foreign import ccall checkFieldsC4 :: Ptr C4 -> Ptr C4 -> IO Int8+foreign import ccall checkOffsetsC4 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC4 :: IO Int16+foreign import ccall getAlignmentC4 :: IO Int16++data C5 = C5 Int32 Int16 Int8 Int8 Int8+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C5 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC5 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC5 offs+    getSize        a          = fromIntegral <$> getSizeC5+    getAlignment   a          = fromIntegral <$> getAlignmentC5+    new (C5 a b c d e) = do+        ptr <- newC5 a b c d e+        return ptr++instance Arbitrary C5 where +    arbitrary = C5 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC5 :: Int32 -> Int16 -> Int8 -> Int8 -> Int8 -> IO (Ptr C5)+foreign import ccall checkFieldsC5 :: Ptr C5 -> Ptr C5 -> IO Int8+foreign import ccall checkOffsetsC5 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC5 :: IO Int16+foreign import ccall getAlignmentC5 :: IO Int16++data C6 = C6 Int64 Int8 Int64+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C6 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC6 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC6 offs+    getSize        a          = fromIntegral <$> getSizeC6+    getAlignment   a          = fromIntegral <$> getAlignmentC6+    new (C6 a b c) = do+        ptr <- newC6 a b c+        return ptr++instance Arbitrary C6 where +    arbitrary = C6 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC6 :: Int64 -> Int8 -> Int64 -> IO (Ptr C6)+foreign import ccall checkFieldsC6 :: Ptr C6 -> Ptr C6 -> IO Int8+foreign import ccall checkOffsetsC6 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC6 :: IO Int16+foreign import ccall getAlignmentC6 :: IO Int16++data C7 = C7 C1 Int32+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C7 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC7 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC7 offs+    getSize        a          = fromIntegral <$> getSizeC7+    getAlignment   a          = fromIntegral <$> getAlignmentC7+    new (C7 a b) = do+        ptr_a <- newStorable a+        ptr <- newC7 ptr_a b+        free ptr_a+        return ptr++instance Arbitrary C7 where +    arbitrary = C7 <$> arbitrary <*> arbitrary++foreign import ccall newC7 :: Ptr C1 -> Int32 -> IO (Ptr C7)+foreign import ccall checkFieldsC7 :: Ptr C7 -> Ptr C7 -> IO Int8+foreign import ccall checkOffsetsC7 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC7 :: IO Int16+foreign import ccall getAlignmentC7 :: IO Int16++data C8 = C8 C2 Int8 C4+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C8 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC8 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC8 offs+    getSize        a          = fromIntegral <$> getSizeC8+    getAlignment   a          = fromIntegral <$> getAlignmentC8+    new (C8 a b c) = do+        ptr_a <- newStorable a+        ptr_c <- newStorable c+        ptr <- newC8 ptr_a b ptr_c+        free ptr_a+        free ptr_c+        return ptr++instance Arbitrary C8 where +    arbitrary = C8 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC8 :: Ptr C2 -> Int8 -> Ptr C4 -> IO (Ptr C8)+foreign import ccall checkFieldsC8 :: Ptr C8 -> Ptr C8 -> IO Int8+foreign import ccall checkOffsetsC8 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC8 :: IO Int16+foreign import ccall getAlignmentC8 :: IO Int16++data C9 = C9 C5 Int8 Int8 Int8+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C9 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC9 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC9 offs+    getSize        a          = fromIntegral <$> getSizeC9+    getAlignment   a          = fromIntegral <$> getAlignmentC9+    new (C9 a b c d) = do+        ptr_a <- newStorable a+        ptr <- newC9 ptr_a b c d+        free ptr_a+        return ptr++instance Arbitrary C9 where +    arbitrary = C9 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC9 :: Ptr C5 -> Int8 -> Int8 -> Int8 -> IO (Ptr C9)+foreign import ccall checkFieldsC9 :: Ptr C9 -> Ptr C9 -> IO Int8+foreign import ccall checkOffsetsC9 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC9 :: IO Int16+foreign import ccall getAlignmentC9 :: IO Int16++data C10 = C10 C8 Int64 C1+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C10 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC10 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC10 offs+    getSize        a          = fromIntegral <$> getSizeC10+    getAlignment   a          = fromIntegral <$> getAlignmentC10+    new (C10 a b c) = do+        ptr_a <- newStorable a+        ptr_c <- newStorable c+        ptr <- newC10 ptr_a b ptr_c+        free ptr_a+        free ptr_c+        return ptr++instance Arbitrary C10 where +    arbitrary = C10 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC10 :: Ptr C8 -> Int64 -> Ptr C1 -> IO (Ptr C10)+foreign import ccall checkFieldsC10 :: Ptr C10 -> Ptr C10 -> IO Int8+foreign import ccall checkOffsetsC10 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC10 :: IO Int16+foreign import ccall getAlignmentC10 :: IO Int16++data C11 = C11 C10 C10+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C11 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC11 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC11 offs+    getSize        a          = fromIntegral <$> getSizeC11+    getAlignment   a          = fromIntegral <$> getAlignmentC11+    new (C11 a b) = do+        ptr_a <- newStorable a+        ptr_b <- newStorable b+        ptr <- newC11 ptr_a ptr_b+        free ptr_a+        free ptr_b+        return ptr++instance Arbitrary C11 where +    arbitrary = C11 <$> arbitrary <*> arbitrary++foreign import ccall newC11 :: Ptr C10 -> Ptr C10 -> IO (Ptr C11)+foreign import ccall checkFieldsC11 :: Ptr C11 -> Ptr C11 -> IO Int8+foreign import ccall checkOffsetsC11 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC11 :: IO Int16+foreign import ccall getAlignmentC11 :: IO Int16++data C12 = C12 Int64 Int64 Int64 Int64+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C12 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC12 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC12 offs+    getSize        a          = fromIntegral <$> getSizeC12+    getAlignment   a          = fromIntegral <$> getAlignmentC12+    new (C12 a b c d) = do+        ptr <- newC12 a b c d+        return ptr++instance Arbitrary C12 where +    arbitrary = C12 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC12 :: Int64 -> Int64 -> Int64 -> Int64 -> IO (Ptr C12)+foreign import ccall checkFieldsC12 :: Ptr C12 -> Ptr C12 -> IO Int8+foreign import ccall checkOffsetsC12 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC12 :: IO Int16+foreign import ccall getAlignmentC12 :: IO Int16++data C13 = C13 C12 C12 C12 C12+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C13 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC13 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC13 offs+    getSize        a          = fromIntegral <$> getSizeC13+    getAlignment   a          = fromIntegral <$> getAlignmentC13+    new (C13 a b c d) = do+        ptr_a <- newStorable a+        ptr_b <- newStorable b+        ptr_c <- newStorable c+        ptr_d <- newStorable d+        ptr <- newC13 ptr_a ptr_b ptr_c ptr_d+        free ptr_a+        free ptr_b+        free ptr_c+        free ptr_d+        return ptr++instance Arbitrary C13 where +    arbitrary = C13 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC13 :: Ptr C12 -> Ptr C12 -> Ptr C12 -> Ptr C12 -> IO (Ptr C13)+foreign import ccall checkFieldsC13 :: Ptr C13 -> Ptr C13 -> IO Int8+foreign import ccall checkOffsetsC13 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC13 :: IO Int16+foreign import ccall getAlignmentC13 :: IO Int16++data C14 = C14 C13 C13 C13 C13 Int8+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C14 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC14 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC14 offs+    getSize        a          = fromIntegral <$> getSizeC14+    getAlignment   a          = fromIntegral <$> getAlignmentC14+    new (C14 a b c d e) = do+        ptr_a <- newStorable a+        ptr_b <- newStorable b+        ptr_c <- newStorable c+        ptr_d <- newStorable d+        ptr <- newC14 ptr_a ptr_b ptr_c ptr_d e+        free ptr_a+        free ptr_b+        free ptr_c+        free ptr_d+        return ptr++instance Arbitrary C14 where +    arbitrary = C14 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC14 :: Ptr C13 -> Ptr C13 -> Ptr C13 -> Ptr C13 -> Int8 -> IO (Ptr C14)+foreign import ccall checkFieldsC14 :: Ptr C14 -> Ptr C14 -> IO Int8+foreign import ccall checkOffsetsC14 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC14 :: IO Int16+foreign import ccall getAlignmentC14 :: IO Int16++data C15 = C15 C12 C14+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C15 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC15 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC15 offs+    getSize        a          = fromIntegral <$> getSizeC15+    getAlignment   a          = fromIntegral <$> getAlignmentC15+    new (C15 a b) = do+        ptr_a <- newStorable a+        ptr_b <- newStorable b+        ptr <- newC15 ptr_a ptr_b+        free ptr_a+        free ptr_b+        return ptr++instance Arbitrary C15 where +    arbitrary = C15 <$> arbitrary <*> arbitrary++foreign import ccall newC15 :: Ptr C12 -> Ptr C14 -> IO (Ptr C15)+foreign import ccall checkFieldsC15 :: Ptr C15 -> Ptr C15 -> IO Int8+foreign import ccall checkOffsetsC15 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC15 :: IO Int16+foreign import ccall getAlignmentC15 :: IO Int16++data C16 = C16 C10 C15 C7+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C16 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC16 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC16 offs+    getSize        a          = fromIntegral <$> getSizeC16+    getAlignment   a          = fromIntegral <$> getAlignmentC16+    new (C16 a b c) = do+        ptr_a <- newStorable a+        ptr_b <- newStorable b+        ptr_c <- newStorable c+        ptr <- newC16 ptr_a ptr_b ptr_c+        free ptr_a+        free ptr_b+        free ptr_c+        return ptr++instance Arbitrary C16 where +    arbitrary = C16 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC16 :: Ptr C10 -> Ptr C15 -> Ptr C7 -> IO (Ptr C16)+foreign import ccall checkFieldsC16 :: Ptr C16 -> Ptr C16 -> IO Int8+foreign import ccall checkOffsetsC16 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC16 :: IO Int16+foreign import ccall getAlignmentC16 :: IO Int16++data C17 = C17 Float Double Float+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C17 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC17 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC17 offs+    getSize        a          = fromIntegral <$> getSizeC17+    getAlignment   a          = fromIntegral <$> getAlignmentC17+    new (C17 a b c) = do+        ptr <- newC17 a b c+        return ptr++instance Arbitrary C17 where +    arbitrary = C17 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC17 :: Float -> Double -> Float -> IO (Ptr C17)+foreign import ccall checkFieldsC17 :: Ptr C17 -> Ptr C17 -> IO Int8+foreign import ccall checkOffsetsC17 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC17 :: IO Int16+foreign import ccall getAlignmentC17 :: IO Int16++data C18 = C18 Float Float Double Float+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C18 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC18 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC18 offs+    getSize        a          = fromIntegral <$> getSizeC18+    getAlignment   a          = fromIntegral <$> getAlignmentC18+    new (C18 a b c d) = do+        ptr <- newC18 a b c d+        return ptr++instance Arbitrary C18 where +    arbitrary = C18 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC18 :: Float -> Float -> Double -> Float -> IO (Ptr C18)+foreign import ccall checkFieldsC18 :: Ptr C18 -> Ptr C18 -> IO Int8+foreign import ccall checkOffsetsC18 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC18 :: IO Int16+foreign import ccall getAlignmentC18 :: IO Int16++data C19 = C19 C17 Float Double+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C19 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC19 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC19 offs+    getSize        a          = fromIntegral <$> getSizeC19+    getAlignment   a          = fromIntegral <$> getAlignmentC19+    new (C19 a b c) = do+        ptr_a <- newStorable a+        ptr <- newC19 ptr_a b c+        free ptr_a+        return ptr++instance Arbitrary C19 where +    arbitrary = C19 <$> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC19 :: Ptr C17 -> Float -> Double -> IO (Ptr C19)+foreign import ccall checkFieldsC19 :: Ptr C19 -> Ptr C19 -> IO Int8+foreign import ccall checkOffsetsC19 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC19 :: IO Int16+foreign import ccall getAlignmentC19 :: IO Int16++data C20 = C20 Double C18 Double C19+    deriving (Show, Eq, Generic, GStorable)++instance Checkable C20 where+    checkFields    ptr1 ptr2 = (==1) <$> checkFieldsC20 ptr1 ptr2+    checkOffsets   _    offs = (==1) <$> checkOffsetsC20 offs+    getSize        a          = fromIntegral <$> getSizeC20+    getAlignment   a          = fromIntegral <$> getAlignmentC20+    new (C20 a b c d) = do+        ptr_b <- newStorable b+        ptr_d <- newStorable d+        ptr <- newC20 a ptr_b c ptr_d+        free ptr_b+        free ptr_d+        return ptr++instance Arbitrary C20 where +    arbitrary = C20 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC20 :: Double -> Ptr C18 -> Double -> Ptr C19 -> IO (Ptr C20)+foreign import ccall checkFieldsC20 :: Ptr C20 -> Ptr C20 -> IO Int8+foreign import ccall checkOffsetsC20 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC20 :: IO Int16+foreign import ccall getAlignmentC20 :: IO Int16+

@@ -0,0 +1,239 @@+{-#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) )+

@@ -0,0 +1,218 @@+{-#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+                )

@@ -0,0 +1,130 @@+{-#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 

@@ -0,0 +1,158 @@+{-#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+                ) 

@@ -0,0 +1,29 @@+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` []