diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/derive-storable.cabal b/derive-storable.cabal --- a/derive-storable.cabal +++ b/derive-storable.cabal @@ -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 diff --git a/src/Foreign/Storable/Generic/Internal.hs b/src/Foreign/Storable/Generic/Internal.hs --- a/src/Foreign/Storable/Generic/Internal.hs +++ b/src/Foreign/Storable/Generic/Internal.hs @@ -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 diff --git a/src/Foreign/Storable/Generic/Tools/TypeFuns.hs b/src/Foreign/Storable/Generic/Tools/TypeFuns.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Tools/TypeFuns.hs @@ -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)) diff --git a/test/Basic/MemoryCSpec.hs b/test/Basic/MemoryCSpec.hs --- a/test/Basic/MemoryCSpec.hs +++ b/test/Basic/MemoryCSpec.hs @@ -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 diff --git a/test/Basic/TestCases.hs b/test/Basic/TestCases.hs --- a/test/Basic/TestCases.hs +++ b/test/Basic/TestCases.hs @@ -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 diff --git a/test/Basic/cbits/TestCases.c b/test/Basic/cbits/TestCases.c --- a/test/Basic/cbits/TestCases.c +++ b/test/Basic/cbits/TestCases.c @@ -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); +} + diff --git a/test/GenericRep/GenericType.hs b/test/GenericRep/GenericType.hs deleted file mode 100644 --- a/test/GenericRep/GenericType.hs +++ /dev/null @@ -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) ) - diff --git a/test/Spec/Foreign/Storable/Generic/Internal/GStorable'Spec.hs b/test/Spec/Foreign/Storable/Generic/Internal/GStorable'Spec.hs deleted file mode 100644 --- a/test/Spec/Foreign/Storable/Generic/Internal/GStorable'Spec.hs +++ /dev/null @@ -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 - ) diff --git a/test/Spec/Foreign/Storable/Generic/Internal/GStorableSpec.hs b/test/Spec/Foreign/Storable/Generic/Internal/GStorableSpec.hs deleted file mode 100644 --- a/test/Spec/Foreign/Storable/Generic/Internal/GStorableSpec.hs +++ /dev/null @@ -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 diff --git a/test/Spec/Foreign/Storable/Generic/InternalSpec.hs b/test/Spec/Foreign/Storable/Generic/InternalSpec.hs deleted file mode 100644 --- a/test/Spec/Foreign/Storable/Generic/InternalSpec.hs +++ /dev/null @@ -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 - ) diff --git a/test/Spec/Foreign/Storable/Generic/ToolsSpec.hs b/test/Spec/Foreign/Storable/Generic/ToolsSpec.hs deleted file mode 100644 --- a/test/Spec/Foreign/Storable/Generic/ToolsSpec.hs +++ /dev/null @@ -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` [] diff --git a/test/Spec/Spec.hs b/test/Spec/Spec.hs deleted file mode 100644 --- a/test/Spec/Spec.hs +++ /dev/null @@ -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) - -