derive-storable-plugin 0.2.2.0 → 0.2.3.0
raw patch · 31 files changed
+2847/−328 lines, 31 filesdep −ghc-pathsdep ~basedep ~derive-storabledep ~ghcPVP ok
version bump matches the API change (PVP)
Dependencies removed: ghc-paths
Dependency ranges changed: base, derive-storable, ghc, ghci
API changes (from Hackage documentation)
+ Foreign.Storable.Generic.Plugin.Internal.Helpers: isProxy :: TyVarBinder -> Bool
+ Foreign.Storable.Generic.Plugin.Internal.Helpers: removeProxy :: Type -> Type
+ Foreign.Storable.Generic.Plugin.Internal.Predicates: isChoiceAlignmentId :: Id -> Bool
+ Foreign.Storable.Generic.Plugin.Internal.Predicates: isChoicePeekId :: Id -> Bool
+ Foreign.Storable.Generic.Plugin.Internal.Predicates: isChoicePokeId :: Id -> Bool
+ Foreign.Storable.Generic.Plugin.Internal.Predicates: isChoiceSizeOfId :: Id -> Bool
Files
- ChangeLog.md +6/−0
- benchmark/Main.hs +49/−0
- benchmark/TestCases.hs +86/−1
- benchmark/TestCasesOptimized.hs +13/−2
- derive-storable-plugin.cabal +21/−46
- src/Foreign/Storable/Generic/Plugin.hs +0/−1
- src/Foreign/Storable/Generic/Plugin/Internal.hs +2/−1
- src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs +45/−9
- src/Foreign/Storable/Generic/Plugin/Internal/Error.hs +2/−1
- src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs +91/−4
- src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs +48/−4
- src/Foreign/Storable/Generic/Plugin/Internal/Types.hs +35/−9
- test/Basic/MemoryCSpec.hs +145/−0
- test/Basic/TestCases.hs +797/−0
- test/Basic/cbits/TestCases.c +1507/−0
- test/ids/Concrete/Instances.hs +0/−10
- test/ids/Concrete/Main.hs +0/−7
- test/ids/Concrete/Types.hs +0/−9
- test/ids/Handwritten/Instances.hs +0/−38
- test/ids/Handwritten/Main.hs +0/−7
- test/ids/Handwritten/Types.hs +0/−9
- test/ids/NewType/Instances.hs +0/−11
- test/ids/NewType/Main.hs +0/−7
- test/ids/NewType/Types.hs +0/−16
- test/ids/ParametrisedSpec/Instances.hs +0/−21
- test/ids/ParametrisedSpec/Main.hs +0/−10
- test/ids/ParametrisedSpec/Types.hs +0/−9
- test/ids/ParametrisedSpec/Usage.hs +0/−62
- test/ids/TypeSynonym/Instances.hs +0/−13
- test/ids/TypeSynonym/Main.hs +0/−7
- test/ids/TypeSynonym/Types.hs +0/−14
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for generic-storable-plugin +## 0.2.3.0 -- 2020-03-23++* Support for derive-storable 0.2.0.0+* Bump to 8.8+* Prepared for 8.10+ ## 0.2.2.0 -- 2018-09-29 * Bump to 8.6
benchmark/Main.hs view
@@ -1,6 +1,7 @@ {-#LANGUAGE TypeApplications #-} {-#LANGUAGE AllowAmbiguousTypes #-} {-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE CPP #-} import Criterion.Main import Criterion.Types@@ -50,6 +51,10 @@ , bench "C3" $ nf sizeOf c3hw_def , bench "C4" $ nf sizeOf c4hw_def , bench "C5" $ nf sizeOf c5hw_def+#ifdef GSTORABLE_SUMTYPES+ , bench "S1" $ nf sizeOf s1hw_def+ , bench "S2" $ nf sizeOf s2hw_def+#endif ] , bgroup "GStorable" $@@ -58,6 +63,10 @@ , bench "C3" $ nf sizeOf c3_def , bench "C4" $ nf sizeOf c4_def , bench "C5" $ nf sizeOf c5_def+#ifdef GSTORABLE_SUMTYPES+ , bench "S1" $ nf sizeOf s1_def+ , bench "S2" $ nf sizeOf s2_def+#endif ] , bgroup "Optimized" $ [ bench "C1" $ nf sizeOf c1o_def@@ -65,6 +74,10 @@ , bench "C3" $ nf sizeOf c3o_def , bench "C4" $ nf sizeOf c4o_def , bench "C5" $ nf sizeOf c5o_def+#ifdef GSTORABLE_SUMTYPES+ , bench "S1" $ nf sizeOf s1o_def+ , bench "S2" $ nf sizeOf s2o_def+#endif ] ] , bgroup "alignment" $ @@ -74,6 +87,10 @@ , bench "C3" $ nf alignment c3hw_def , bench "C4" $ nf alignment c4hw_def , bench "C5" $ nf alignment c5hw_def+#ifdef GSTORABLE_SUMTYPES+ , bench "S1" $ nf alignment s1hw_def+ , bench "S2" $ nf alignment s2hw_def+#endif ] , bgroup "GStorable" $ [ bench "C1" $ nf alignment c1_def@@ -81,6 +98,10 @@ , bench "C3" $ nf alignment c3_def , bench "C4" $ nf alignment c4_def , bench "C5" $ nf alignment c5_def+#ifdef GSTORABLE_SUMTYPES+ , bench "S1" $ nf alignment s1_def+ , bench "S2" $ nf alignment s2_def+#endif ] , bgroup "Optimized" $ [ bench "C1" $ nf alignment c1o_def@@ -88,6 +109,10 @@ , bench "C3" $ nf alignment c3o_def , bench "C4" $ nf alignment c4o_def , bench "C5" $ nf alignment c5o_def+#ifdef GSTORABLE_SUMTYPES+ , bench "S1" $ nf alignment s1o_def+ , bench "S2" $ nf alignment s2o_def+#endif ] ] , bgroup "peek" $@@ -97,6 +122,10 @@ , env (malloc @C3hw) $ \ptr -> bench "C3" $ nfIO (peek ptr) , env (malloc @C4hw) $ \ptr -> bench "C4" $ nfIO (peek ptr) , env (malloc @C5hw) $ \ptr -> bench "C5" $ nfIO (peek ptr)+#ifdef GSTORABLE_SUMTYPES+ , env (malloc @S1hw) $ \ptr -> bench "S1" $ nfIO (peek ptr)+ , env (malloc @S2hw) $ \ptr -> bench "S2" $ nfIO (peek ptr)+#endif ] , bgroup "GStorable" $ [ env (malloc @C1 ) $ \ptr -> bench "C1" $ nfIO (peek ptr)@@ -104,6 +133,10 @@ , env (malloc @C3 ) $ \ptr -> bench "C3" $ nfIO (peek ptr) , env (malloc @C4 ) $ \ptr -> bench "C4" $ nfIO (peek ptr) , env (malloc @C5 ) $ \ptr -> bench "C5" $ nfIO (peek ptr)+#ifdef GSTORABLE_SUMTYPES+ , env (malloc @S1 ) $ \ptr -> bench "S1" $ nfIO (peek ptr)+ , env (malloc @S2 ) $ \ptr -> bench "S2" $ nfIO (peek ptr)+#endif ] , bgroup "Optimized" $ [ env (malloc @C1O ) $ \ptr -> bench "C1" $ nfIO ((gpeekByteOff ptr 0) :: IO C1O)@@ -111,6 +144,10 @@ , env (malloc @C3O ) $ \ptr -> bench "C3" $ nfIO (peek ptr) , env (malloc @C4O ) $ \ptr -> bench "C4" $ nfIO (peek ptr) , env (malloc @C5O ) $ \ptr -> bench "C5" $ nfIO (peek ptr)+#ifdef GSTORABLE_SUMTYPES+ , env (malloc @S1O ) $ \ptr -> bench "S1" $ nfIO (peek ptr)+ , env (malloc @S2O ) $ \ptr -> bench "S2" $ nfIO (peek ptr)+#endif ] ] , bgroup "poke" $@@ -120,6 +157,10 @@ , env malloc $ \ptr -> bench "C3" $ nfIO (poke ptr c3hw_def) , env malloc $ \ptr -> bench "C4" $ nfIO (poke ptr c4hw_def) , env malloc $ \ptr -> bench "C5" $ nfIO (poke ptr c5hw_def)+#ifdef GSTORABLE_SUMTYPES+ , env malloc $ \ptr -> bench "S1" $ nfIO (poke ptr s1hw_def)+ , env malloc $ \ptr -> bench "S2" $ nfIO (poke ptr s2hw_def)+#endif ] , bgroup "GStorable" $ [ env malloc $ \ptr -> bench "C1" $ nfIO (poke ptr c1_def) @@ -127,6 +168,10 @@ , env malloc $ \ptr -> bench "C3" $ nfIO (poke ptr c3_def) , env malloc $ \ptr -> bench "C4" $ nfIO (poke ptr c4_def) , env malloc $ \ptr -> bench "C5" $ nfIO (poke ptr c5_def)+#ifdef GSTORABLE_SUMTYPES+ , env malloc $ \ptr -> bench "S1" $ nfIO (poke ptr s1_def)+ , env malloc $ \ptr -> bench "S2" $ nfIO (poke ptr s2_def)+#endif ] , bgroup "Optimized" $ [ env malloc $ \ptr -> bench "C1" $ nfIO (poke ptr c1o_def) @@ -134,6 +179,10 @@ , env malloc $ \ptr -> bench "C3" $ nfIO (poke ptr c3o_def) , env malloc $ \ptr -> bench "C4" $ nfIO (poke ptr c4o_def) , env malloc $ \ptr -> bench "C5" $ nfIO (poke ptr c5o_def)+#ifdef GSTORABLE_SUMTYPES+ , env malloc $ \ptr -> bench "S1" $ nfIO (poke ptr s1o_def)+ , env malloc $ \ptr -> bench "S2" $ nfIO (poke ptr s2o_def)+#endif ] ] ]
benchmark/TestCases.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, CPP #-} module TestCases where import GHC.Generics (Generic) import Foreign.Storable.Generic import Data.Int+import Data.Word import Control.DeepSeq @@ -87,3 +88,87 @@ pokeByteOff ptr off i32 pokeByteOff ptr (off + 4) c2hw pokeByteOff ptr (off + 16) c4hw++#ifdef GSTORABLE_SUMTYPES++data S1 = S1a Int32 | S1b Int16 deriving (Show, Generic, GStorable, NFData)+data S2 = S2a Int32 Int64 Int8 | S2b S1 Int8 Double+ | S2c Int32 Int8 Int16 Int8 | S2d S1 S1+ deriving (Show, Generic, GStorable, NFData)++s1_def = S1a 54+s2_def = S2b s1_def 32 1.5+++data S1hw = S1hwa Int32 | S1hwb Int16 deriving (Show,Generic, NFData)+data S2hw = S2hwa Int32 Int64 Int8 | S2hwb S1hw Int8 Double+ | S2hwc Int32 Int8 Int16 Int8 | S2hwd S1hw S1hw+ deriving (Show, Generic, NFData)++s1hw_def = S1hwa 54+s2hw_def = S2hwb s1hw_def 32 1.5++instance Storable S1hw where+ sizeOf _ = 8+ alignment _ = 4+ peekByteOff ptr off = do + let peek1 = S1hwa <$> (peekByteOff ptr (off+4) :: IO Int32)+ peek2 = S1hwb <$> (peekByteOff ptr (off+4) :: IO Int16)+ tag <- peekByteOff ptr off :: IO Word8 + case tag of+ 0 -> peek1+ 1 -> peek2+ _ -> error "S1hw : Bad tag"+ pokeByteOff ptr off (S1hwa v) = pokeByteOff ptr off (0 :: Word8) >> pokeByteOff ptr (off+4) v+ pokeByteOff ptr off (S1hwb v) = pokeByteOff ptr off (1 :: Word8) >> pokeByteOff ptr (off+4) v++instance Storable S2hw where+ sizeOf _ = 32+ alignment _ = 8+ peekByteOff ptr off = do + let peek1 = S2hwa <$> (peekByteOff ptr (off+ 8) :: IO Int32)+ <*> (peekByteOff ptr (off+16) :: IO Int64)+ <*> (peekByteOff ptr (off+24) :: IO Int8)++ peek2 = S2hwb <$> (peekByteOff ptr (off+ 8) :: IO S1hw)+ <*> (peekByteOff ptr (off+16) :: IO Int8)+ <*> (peekByteOff ptr (off+24) :: IO Double)++ peek3 = S2hwc <$> (peekByteOff ptr (off+ 8) :: IO Int32)+ <*> (peekByteOff ptr (off+12) :: IO Int8)+ <*> (peekByteOff ptr (off+16) :: IO Int16)+ <*> (peekByteOff ptr (off+20) :: IO Int8)++ peek4 = S2hwd <$> (peekByteOff ptr (off+ 8) :: IO S1hw)+ <*> (peekByteOff ptr (off+16) :: IO S1hw)++ tag <- peekByteOff ptr off :: IO Word8 + case tag of+ 0 -> peek1+ 1 -> peek2+ 2 -> peek3+ 3 -> peek4+ _ -> error "S1hw : Bad tag"++ pokeByteOff ptr off (S2hwa a b c) = do + pokeByteOff ptr off (0 :: Word8) + pokeByteOff ptr (off+ 8) a+ pokeByteOff ptr (off+16) b+ pokeByteOff ptr (off+24) c+ pokeByteOff ptr off (S2hwb a b c) = do+ pokeByteOff ptr off (1 :: Word8) + pokeByteOff ptr (off+ 8) a+ pokeByteOff ptr (off+16) b+ pokeByteOff ptr (off+24) c+ pokeByteOff ptr off (S2hwc a b c d) = do+ pokeByteOff ptr off (2 :: Word8) + pokeByteOff ptr (off+ 8) a+ pokeByteOff ptr (off+12) b+ pokeByteOff ptr (off+16) c+ pokeByteOff ptr (off+24) d+ pokeByteOff ptr off (S2hwd a b) = do+ pokeByteOff ptr off (3 :: Word8) + pokeByteOff ptr (off+ 8) a+ pokeByteOff ptr (off+16) b++#endif
benchmark/TestCasesOptimized.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, CPP #-} {-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-} {-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} {-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v2 #-} @@ -15,9 +15,20 @@ data C3O = C3O C2O Int64 C1O deriving (Show, Generic, GStorable, NFData) data C4O = C4O Double Int8 C3O deriving (Show, Generic, GStorable, NFData) data C5O = C5O Int32 C2O C4O deriving (Show, Generic, GStorable, NFData)- c1o_def = C1O 3 c2o_def = C2O 3 10 8 c3o_def = C3O c2o_def 11000 c1o_def c4o_def = C4O 0.312 3 c3o_def c5o_def = C5O 100 c2o_def c4o_def ++#ifdef GSTORABLE_SUMTYPES++data S1O = S1Oa Int32 | S1Ob Int16 deriving (Show, Generic, GStorable, NFData)+data S2O = S2Oa Int32 Int64 Int8 | S2Ob S1O Int8 Double+ | S2Oc Int32 Int8 Int16 Int8 | S2Od S1O S1O+ deriving (Show, Generic, GStorable, NFData)++s1o_def = S1Oa 54+s2o_def = S2Ob s1o_def 32 1.5++#endif
derive-storable-plugin.cabal view
@@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: derive-storable-plugin-version: 0.2.2.0+version: 0.2.3.0 synopsis: GHC core plugin supporting the derive-storable package. description: The package helps derive-storable package in forcing compile time evaluation of sizes, alignments and offsets.@@ -16,11 +16,11 @@ build-type: Simple 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.6.1+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.2, GHC==8.6.5, GHC==8.8.1 -source-repository head- type: git- location: https://www.github.com/mkloczko/derive-storable-plugin/+Flag sumtypes+ Description: Use sumtypes within the benchmark and the test.+ Default: False library exposed-modules: Foreign.Storable.Generic.Plugin@@ -33,7 +33,7 @@ , Foreign.Storable.Generic.Plugin.Internal.Types -- other-modules: other-extensions: DeriveGeneric, DeriveAnyClass, PatternGuards- build-depends: base >=4.9 && <4.13, ghc >= 8.0 && <8.7, ghci >= 8.0 && <8.7, derive-storable >= 0.1.1 && < 0.2+ build-depends: base >=4.9 && <4.14, ghc >= 8.0 && <8.9, ghci >= 8.0 && <8.9, derive-storable >= 0.1.1 && < 0.3 hs-source-dirs: src default-language: Haskell2010 @@ -43,49 +43,24 @@ default-language: Haskell2010 other-modules: TestCases, TestCasesOptimized Main-is: Main.hs- build-depends: base >= 4.9 && < 4.13, deepseq, criterion >= 1.1.0+ build-depends: base >= 4.9 && < 4.14, deepseq, criterion >= 1.1.0 , derive-storable, derive-storable-plugin-test-suite ids-concrete- type: exitcode-stdio-1.0- hs-source-dirs: test/ids/Concrete- default-language: Haskell2010- other-modules: Types, Instances- Main-is: Main.hs- build-depends: base >= 4.9 && < 4.13, ghc >= 8.0 && <8.7, ghci >= 8.0 && <8.7, ghc-paths- , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10 -test-suite ids-handwritten- type: exitcode-stdio-1.0- hs-source-dirs: test/ids/Handwritten- default-language: Haskell2010- other-modules: Types, Instances- Main-is: Main.hs- build-depends: base >= 4.9 && < 4.13, ghc >= 8.0 && <8.7, ghci >= 8.0 && <8.7, ghc-paths- , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10--test-suite ids-newtype- type: exitcode-stdio-1.0- hs-source-dirs: test/ids/NewType- default-language: Haskell2010- other-modules: Types, Instances- Main-is: Main.hs- build-depends: base >= 4.9 && < 4.13, ghc >= 8.0 && <8.7, ghci >= 8.0 && <8.7, ghc-paths- , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10+ if flag(sumtypes)+ cpp-options: -DGSTORABLE_SUMTYPES -test-suite ids-parametrised-spec+test-suite c_alignment type: exitcode-stdio-1.0- hs-source-dirs: test/ids/ParametrisedSpec+ + hs-source-dirs: test/Basic, test/Basic/cbits+ c-sources: test/Basic/cbits/TestCases.c + main-is: MemoryCSpec.hs+ other-modules: TestCases + build-depends: base >= 4.8 && < 5, derive-storable, derive-storable-plugin+ , hspec >= 2.4, QuickCheck >= 2.10+ , ghc >= 8.0 && <8.9, ghci >= 8.0 && <8.9+ default-language: Haskell2010- other-modules: Types, Instances, Usage- Main-is: Main.hs- build-depends: base >= 4.9 && < 4.13, ghc >= 8.0 && <8.7, ghci >= 8.0 && <8.7, ghc-paths- , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10+ if flag(sumtypes)+ cpp-options: -DGSTORABLE_SUMTYPES -test-suite ids-typesynonym- type: exitcode-stdio-1.0- hs-source-dirs: test/ids/TypeSynonym- default-language: Haskell2010- other-modules: Types, Instances- Main-is: Main.hs- build-depends: base >= 4.9 && < 4.13, ghc >= 8.0 && <8.7, ghci >= 8.0 && <8.7, ghc-paths- , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10
src/Foreign/Storable/Generic/Plugin.hs view
@@ -36,7 +36,6 @@ defFlags = Flags Some False - orderingPass :: Flags -> IORef [[Type]] -> CoreToDo orderingPass flags io_ref = CoreDoPluginPass "GStorable - type ordering" (groupTypes flags io_ref)
src/Foreign/Storable/Generic/Plugin/Internal.hs view
@@ -230,7 +230,8 @@ typeCheck t = if hasGStorableConstraints t then Nothing else getGStorableMethodType t- predicate = toIsBind (withTypeCheck typeCheck isGStorableMethodId)+ -- predicate = toIsBind (withTypeCheck typeCheck isGStorableMethodId)+ predicate = toIsBind (isGStorableMethodId) (gstorable_binds,rest) = partition predicate binds -- Check if there are any recursives somehow
src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs view
@@ -145,20 +145,55 @@ -- | For gsizeOf and galignment - calculate the variables. intSubstitution :: CoreBind -> CoreM (Either Error CoreBind) intSubstitution b@(Rec _) = return $ Left $ CompilationNotSupported b-intSubstitution b@(NonRec id (Lam _ (Lam _ _))) = return $ Left $ CompilationNotSupported b -intSubstitution b@(NonRec id (Lam _ expr)) = do+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+#endif+-- For GSTORABLE_SUMTYPES+intSubstitution b@(NonRec id (Lam l1 l@(Lam l2 e@(Lam l3 expr)))) = do -- Get HscEnv hsc_env <- getHscEnv -- Try the subtitution. the_integer <- tryCompileExpr id expr :: CoreM (Either Error Int)- -- Get the type. let m_t = getGStorableType (varType id) case m_t of+ Just t -> return $ NonRec id <$> (Lam l1 <$> (Lam l2 <$> (intToExpr t <$> the_integer)))+ Nothing -> + return the_integer >> return $ Left $ CompilationError b (text "Type not found")+-- Without GSTORABLE_SUMPTYPES+intSubstitution b@(NonRec id (Lam l1 expr)) = do+ -- Get HscEnv+ hsc_env <- getHscEnv+ -- Try the subtitution.+ the_integer <- tryCompileExpr id expr :: CoreM (Either Error Int)+ let m_t = getGStorableType (varType id) + case m_t of Just t -> return $ NonRec id <$> (intToExpr t <$> the_integer)- -- If the compilation error occured, first return it. Nothing -> return the_integer >> return $ Left $ CompilationError b (text "Type not found")+-- For GHC <= 8.6.5+intSubstitution b@(NonRec id e@(App expr g)) = case expr of+ Lam _ (Lam _ (Lam _ e)) -> intSubstitution $ NonRec id expr+ App e t -> do + subs <- intSubstitution $ NonRec id e+ case subs of+ Right (NonRec i (Lam l1 (Lam l2 e)) ) -> return (Right $ NonRec i e)+ err -> return err+ _ -> intSubstitutionWorker id expr+intSubstitution b@(NonRec id (Case _ _ _ _)) = error $ "am case"+intSubstitution b@(NonRec id (Let _ _)) = error $ "am let"+intSubstitution b@(NonRec id e) = error $ showSDocUnsafe $ ppr e +intSubstitutionWorker id expr = do+ -- Get HscEnv+ hsc_env <- getHscEnv+ -- Try the subtitution.+ the_integer <- tryCompileExpr id expr :: CoreM (Either Error Int)+ -- Get the type.+ let m_t = getGStorableType (varType id) + case m_t of+ Just t -> return $ NonRec id <$> (intToExpr t <$> the_integer)+ -- If the compilation error occured, first return it.+ Nothing -> + return the_integer >> return $ Left $ CompilationError (NonRec id expr) (text "Type not found") ----------------------- -- peek substitution -- -----------------------@@ -168,7 +203,6 @@ offsetSubstitution b@(Rec _) = return $ Left $ CompilationNotSupported b offsetSubstitution b@(NonRec id expr) = do e_subs <- offsetSubstitutionTree [] expr- let ne_subs = case e_subs of -- Add the text from other error. Left (OtherError sdoc) @@ -336,6 +370,8 @@ return $ Tick t <$> subs -- Leave types alone. offsetSubstitutionTree scope e@(Type _ ) = return $ Right e+-- And coercions too.+offsetSubstitutionTree scope e@(Coercion _) = return $ Right e -- Do substitutions for the lambda body. offsetSubstitutionTree scope e@(Lam b expr) = do subs <- offsetSubstitutionTree scope expr@@ -418,19 +454,19 @@ compileGStorableBind core_bind -- Substitute gsizeOf | (NonRec id expr) <- core_bind- , isSizeOfId id || isSpecSizeOfId id + , isSizeOfId id || isSpecSizeOfId id || isChoiceSizeOfId id = intSubstitution core_bind -- Substitute galignment | (NonRec id expr) <- core_bind- , isAlignmentId id || isSpecAlignmentId id + , isAlignmentId id || isSpecAlignmentId id || isChoiceAlignmentId id = intSubstitution core_bind -- Substitute offsets in peeks. | (NonRec id expr) <- core_bind- , isPeekId id || isSpecPeekId id+ , isPeekId id || isSpecPeekId id || isChoicePeekId id = offsetSubstitution core_bind -- Substitute offsets in pokes. | (NonRec id expr) <- core_bind- , isPokeId id || isSpecPokeId id+ , isPokeId id || isSpecPokeId id || isChoicePokeId id = offsetSubstitution core_bind -- Everything else - nope. | otherwise = return $ Left $ CompilationNotSupported core_bind
src/Foreign/Storable/Generic/Plugin/Internal/Error.hs view
@@ -101,6 +101,7 @@ $+$ nest 4 (ppr bind) $+$ text "" + pprOrderingFailedTypes :: Verbosity -> Int -> [Type] -> SDoc pprOrderingFailedTypes None _ _ = empty pprOrderingFailedTypes Some depth types @@ -114,7 +115,7 @@ pprOrderingFailedBinds Some depth binds = text "CoreBind ordering failed at depth" <+> int depth <+> text "for bindings:" $$ nest 4 (vcat ppr_ids)- where ppr_ids = map (\id -> ppr id <+> text "::" <+> ppr (varType id) ) $ concatMap getIdsBind binds+ where ppr_ids = map (\id -> ppr id <+> text "::" <+> ppr (varType id)) $ concatMap getIdsBind binds pprOrderingFailedBinds All depth binds = text "--- CoreBind ordering failed at depth" <+> int depth <+> text "for bindings ---" $+$ text "\n"
src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs view
@@ -17,7 +17,9 @@ import Literal (Literal(..)) import Id (isLocalId, isGlobalId,Id) import Var (Var(..))-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+import Var (TyVarBinder(..), VarBndr(..))+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) import Var (TyVarBndr(..), TyVarBinder) #endif import Name (getOccName,mkOccName)@@ -33,7 +35,11 @@ -- Haskell types import Type (isAlgType, splitTyConApp_maybe) import TyCon (algTyConRhs, visibleDataCons)+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+import TyCoRep (Type(..), TyBinder(..), TyCoBinder(..))+#else import TyCoRep (Type(..), TyBinder(..))+#endif import TysWiredIn (intDataCon) import DataCon (dataConWorkId,dataConOrigArgTys) @@ -52,10 +58,11 @@ import Data.List import Data.Maybe import Data.Either-import Debug.Trace import Control.Monad.IO.Class +import Var + -- | Get ids from core bind. getIdsBind :: CoreBind -> [Id] getIdsBind (NonRec id _) = [id]@@ -116,10 +123,17 @@ #else eqTyBind (Named t1 vis1) (Named t2 vis2) = t1 == t2 && vis1 == vis2 #endif-eqTyBind (Anon t1) (Anon t2) = t1 `eqType` t2+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+eqTyBind (Anon _ t1) (Anon _ t2) = t1 `eqType` t2+#else+eqTyBind (Anon t1) (Anon t2) = t1 `eqType` t2+#endif eqTyBind _ _ = False -#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool+eqTyVarBind (Bndr t1 arg1) (Bndr t2 arg2) = t1 == t2 +#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) -- | Equality for type variable binders eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool eqTyVarBind (TvBndr t1 arg1) (TvBndr t2 arg2) = t1 == t2 @@ -129,3 +143,76 @@ elemType :: Type -> [Type] -> Bool elemType t [] = False elemType t (ot:ts) = (t `eqType` ot) || elemType t ts++#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+isProxy :: TyCoVarBinder -> Bool+isProxy (Bndr tycovar flag) +#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+isProxy :: TyVarBinder -> Bool+isProxy (TvBndr tycovar flag)+#else+isProxy :: TyBinder -> Bool+isProxy (Anon t) = False+isProxy (Named tycovar flag)+#endif+ | isTyCoVar tycovar+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ , FunTy _ bool star <- varType tycovar+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , FunTy bool star <- varType tycovar+#else + , ForAllTy bool star <- varType tycovar+#endif+ = True+ | otherwise = False+++removeProxy :: Type -> Type+removeProxy t+ -- forall (proxy :: Bool -> *)+ | ForAllTy fall t1 <- t+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ , FunTy _ ch t2 <- t1+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , FunTy ch t2 <- t1+#else + , ForAllTy ch' t2 <- t+ , Anon ch <- ch'+#endif+ , AppTy pr bl <- ch+ , TyConApp _ _ <- bl+ , isProxy fall+ = t2+ -- forall (proxy :: Bool -> *) b.+ | ForAllTy fall f2 <- t+ , ForAllTy b t1 <- f2+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ , FunTy _ ch t2 <- t1+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , FunTy ch t2 <- t1+#else + , ForAllTy ch' t2 <- t+ , Anon ch <- ch'+#endif+ , AppTy pr bl <- ch+ , TyConApp _ _ <- bl+ , isProxy fall+ = ForAllTy b t2+ -- forall b (proxy :: Bool -> *).+ | ForAllTy b f2 <- t+ , ForAllTy fall t1 <- f2+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ , FunTy _ ch t2 <- t1+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , FunTy ch t2 <- t1+#else + , ForAllTy ch' t2 <- t+ , Anon ch <- ch'+#endif+ , AppTy pr bl <- ch+ , TyConApp _ _ <- bl+ , isProxy fall+ = ForAllTy b t2+ | otherwise+ = t+
src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs view
@@ -9,6 +9,7 @@ Predicates for finding GStorable identifiers, plus some others. -}+{-#LANGUAGE CPP#-} module Foreign.Storable.Generic.Plugin.Internal.Predicates ( -- Predicates on identifiers@@ -22,6 +23,10 @@ , isSpecAlignmentId , isSpecPeekId , isSpecPokeId+ , isChoiceSizeOfId+ , isChoiceAlignmentId+ , isChoicePeekId+ , isChoicePokeId , isOffsetsId -- Groups of above , isGStorableId@@ -61,14 +66,13 @@ import CoreMonad (putMsg, putMsgS) +import Name (nameStableString) import Data.Maybe import Foreign.Storable.Generic.Plugin.Internal.Helpers -- -- | Predicate used to find GStorable instances identifiers. isGStorableInstId :: Id -> Bool isGStorableInstId id = cutted_occ_name == gstorable_dict_name @@ -88,13 +92,49 @@ -- | Predicate used to find gpeekByteOff identifiers isPeekId :: Id -> Bool-isPeekId ident = getOccName (varName ident) == mkOccName N.varName "$cgpeekByteOff" +isPeekId id = occStr == compared1+ where occStr = nameStableString $ varName id+ compared1 = "$_in$$cgpeekByteOff" -- | Predicate used to find gpeekByteOff identifiers isPokeId :: Id -> Bool-isPokeId ident = getOccName (varName ident) == mkOccName N.varName "$cgpokeByteOff" +isPokeId id = occStr == compared1+ where occStr = nameStableString $ varName id+ compared1 = "$_in$$cgpokeByteOff" +--------------------------------------------+--GStorableChoice methods' identifiers --+-------------------------------------------- +-- | Predicate used to find chSizeOf identifiers+isChoiceSizeOfId :: Id -> Bool+isChoiceSizeOfId id = occStr == compared1 || occStr == compared2+ where occStr = nameStableString $ varName id+ compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchSizeOf"+ compared2 = "$_in$$s$fGStorableChoice'Truea_$cchSizeOf"+ +-- | Predicate used to find chAlignment identifiers+isChoiceAlignmentId :: Id -> Bool+isChoiceAlignmentId id = occStr == compared1 || occStr == compared2+ where occStr = nameStableString $ varName id+ compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchAlignment"+ compared2 = "$_in$$s$fGStorableChoice'Truea_$cchAlignment"++-- | Predicate used to find chPeekByteOff identifiers+isChoicePeekId :: Id -> Bool+isChoicePeekId id = compared1 == occStr || compared2 == occStr+ where occStr = nameStableString $ varName id+ compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchPeekByteOff"+ compared2 = "$_in$$s$fGStorableChoice'Truea_$cchPeekByteOff"++-- | Predicate used to find chPokeByteOff identifiers+isChoicePokeId :: Id -> Bool+isChoicePokeId id = compared1 == occStr || compared2 == occStr+ where occStr = nameStableString $ varName id+ compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchPokeByteOff"+ compared2 = "$_in$$s$fGStorableChoice'Truea_$cchPokeByteOff"++ -------------------------------------------- --Specialized at instance definition site.-- --------------------------------------------@@ -151,6 +191,10 @@ , isPeekId, isPokeId , isSpecSizeOfId, isSpecAlignmentId , isSpecPeekId, isSpecPokeId+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+ , isChoiceSizeOfId, isChoiceAlignmentId+ , isChoicePeekId, isChoicePokeId+#endif ] ------------------ -- Miscellanous --
src/Foreign/Storable/Generic/Plugin/Internal/Types.hs view
@@ -42,7 +42,9 @@ import Literal (Literal(..)) import Id (isLocalId, isGlobalId,Id) import Var (Var(..), isId)-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+import Var (TyVarBinder, VarBndr(..), binderVar)+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) import Var (TyVarBndr(..), TyVarBinder, binderVar) #endif import Name (getOccName,mkOccName)@@ -183,7 +185,12 @@ getAlignmentType t -- Assuming there are no anonymous ty bind between -- the type and the integer, ie no : Type -> forall a. Int-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ | FunTy _ t1 t2 <- t+ -- , isIntType t2+ , TyConApp _ _ <- t2+ , the_t <- t1+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) | FunTy t1 t2 <- t , isIntType t2 , the_t <- t1@@ -201,7 +208,12 @@ getSizeType t -- Assuming there are no anonymous ty bind between -- the type and the integer, ie no : Type -> forall a. Int-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ | FunTy _ t1 t2 <- t+ -- , isIntType t2+ , TyConApp _ _ <- t2+ , the_t <- t1+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) | FunTy t1 t2 <- t , isIntType t2 , the_t <- t1@@ -235,7 +247,9 @@ = Just the_t -- Int -> IO (TheType) | after_ptr-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ , FunTy _ int_t io_t <- t+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) , FunTy int_t io_t <- t #else , ForAllTy ty_bind io_t <- t@@ -244,8 +258,11 @@ , isIntType int_t = getPeekType' io_t True True -- Ptr b -> Int -> IO (TheType)-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) | ForAllTy ty_bind fun_t <- t+ , FunTy _ ptr_t rest <- fun_t +#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ | ForAllTy ty_bind fun_t <- t , FunTy ptr_t rest <- fun_t #else | ForAllTy ty_bind rest <- t@@ -275,7 +292,10 @@ getPokeType' t after_ptr after_int -- Last step: TheType -> IO () | after_ptr, after_int-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ , FunTy _ the_t io_t <- t+ , isIOType io_t+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) , FunTy the_t io_t <- t , isIOType io_t #else@@ -286,7 +306,9 @@ = Just the_t -- Int -> TheType -> IO () | after_ptr-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ , FunTy _ int_t rest <- t+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0) , FunTy int_t rest <- t #else , ForAllTy ty_bind rest <- t@@ -295,8 +317,11 @@ , isIntType int_t = getPokeType' rest True True -- Ptr b -> Int -> TheType -> IO ()-#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) | ForAllTy ty_bind fun_t <- t+ , FunTy _ ptr_t rest <- fun_t+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ | ForAllTy ty_bind fun_t <- t , FunTy ptr_t rest <- fun_t #else | ForAllTy ty_bind rest <- t@@ -323,7 +348,8 @@ -- | Combination of type getters for all GStorables. getGStorableType :: Type -> Maybe Type-getGStorableType t = getGStorableInstType t <|> getSizeType t <|> getAlignmentType t <|> getPokeType t <|> getPeekType t+getGStorableType t' = getGStorableInstType t <|> getSizeType t <|> getAlignmentType t <|> getPokeType t <|> getPeekType t+ where t = removeProxy t' -- | Combination of type getters for GStorable methods. getGStorableMethodType :: Type -> Maybe Type
+ test/Basic/MemoryCSpec.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+module Main where+++-- Tested module.+import TestCases++-- Test libraries+import Test.Hspec+import Test.QuickCheck hiding (getSize)++-- Helpers+import Foreign.Marshal.Array+import Foreign.Storable+++same_alignment a = getAlignment a `shouldReturn` alignment a+same_size a = getSize a `shouldReturn` sizeOf a+same_offsets a = do+ let offsets = goffsets a+ ptr <- mallocArray $ length offsets+ pokeArray ptr offsets+ checkOffsets a ptr `shouldReturn` True++same_fields a = do+ ptr1 <- newStorable a+ ptr2 <- new a+ checkFields ptr1 ptr2 `shouldReturn` True+main = hspec $ do+ describe "Test for same size" $ do+ it "C0" $ property $ (same_size :: C0 -> Expectation)+ it "C1" $ property $ (same_size :: C1 -> Expectation)+ it "C2" $ property $ (same_size :: C2 -> Expectation)+ it "C3" $ property $ (same_size :: C3 -> Expectation)+ it "C4" $ property $ (same_size :: C4 -> Expectation)+ it "C5" $ property $ (same_size :: C5 -> Expectation)+ it "C6" $ property $ (same_size :: C6 -> Expectation)+ it "C7" $ property $ (same_size :: C7 -> Expectation)+ it "C8" $ property $ (same_size :: C8 -> Expectation)+ it "C9" $ property $ (same_size :: C9 -> Expectation)+ it "C10" $ property $ (same_size :: C10 -> Expectation)+ it "C11" $ property $ (same_size :: C11 -> Expectation)+ it "C12" $ property $ (same_size :: C12 -> Expectation)+ it "C13" $ property $ (same_size :: C13 -> Expectation)+ it "C14" $ property $ (same_size :: C14 -> Expectation)+ it "C15" $ property $ (same_size :: C15 -> Expectation)+ it "C16" $ property $ (same_size :: C16 -> Expectation)+ it "C17" $ property $ (same_size :: C17 -> Expectation)+ it "C18" $ property $ (same_size :: C18 -> Expectation)+ it "C19" $ property $ (same_size :: C19 -> Expectation)+ it "C20" $ property $ (same_size :: C20 -> Expectation)+ describe "Test for same alignment" $ do+ it "C0" $ property $ (same_alignment :: C0 -> Expectation)+ it "C1" $ property $ (same_alignment :: C1 -> Expectation)+ it "C2" $ property $ (same_alignment :: C2 -> Expectation)+ it "C3" $ property $ (same_alignment :: C3 -> Expectation)+ it "C4" $ property $ (same_alignment :: C4 -> Expectation)+ it "C5" $ property $ (same_alignment :: C5 -> Expectation)+ it "C6" $ property $ (same_alignment :: C6 -> Expectation)+ it "C7" $ property $ (same_alignment :: C7 -> Expectation)+ it "C8" $ property $ (same_alignment :: C8 -> Expectation)+ it "C9" $ property $ (same_alignment :: C9 -> Expectation)+ it "C10" $ property $ (same_alignment :: C10 -> Expectation)+ it "C11" $ property $ (same_alignment :: C11 -> Expectation)+ it "C12" $ property $ (same_alignment :: C12 -> Expectation)+ it "C13" $ property $ (same_alignment :: C13 -> Expectation)+ it "C14" $ property $ (same_alignment :: C14 -> Expectation)+ it "C15" $ property $ (same_alignment :: C15 -> Expectation)+ it "C16" $ property $ (same_alignment :: C16 -> Expectation)+ it "C17" $ property $ (same_alignment :: C17 -> Expectation)+ it "C18" $ property $ (same_alignment :: C18 -> Expectation)+ it "C19" $ property $ (same_alignment :: C19 -> Expectation)+ it "C20" $ property $ (same_alignment :: C20 -> Expectation)+ describe "Test for same offsets" $ do+ it "C0" $ property $ (same_offsets :: C0 -> Expectation)+ it "C1" $ property $ (same_offsets :: C1 -> Expectation)+ it "C2" $ property $ (same_offsets :: C2 -> Expectation)+ it "C3" $ property $ (same_offsets :: C3 -> Expectation)+ it "C4" $ property $ (same_offsets :: C4 -> Expectation)+ it "C5" $ property $ (same_offsets :: C5 -> Expectation)+ it "C6" $ property $ (same_offsets :: C6 -> Expectation)+ it "C7" $ property $ (same_offsets :: C7 -> Expectation)+ it "C8" $ property $ (same_offsets :: C8 -> Expectation)+ it "C9" $ property $ (same_offsets :: C9 -> Expectation)+ it "C10" $ property $ (same_offsets :: C10 -> Expectation)+ it "C11" $ property $ (same_offsets :: C11 -> Expectation)+ it "C12" $ property $ (same_offsets :: C12 -> Expectation)+ it "C13" $ property $ (same_offsets :: C13 -> Expectation)+ it "C14" $ property $ (same_offsets :: C14 -> Expectation)+ it "C15" $ property $ (same_offsets :: C15 -> Expectation)+ it "C16" $ property $ (same_offsets :: C16 -> Expectation)+ it "C17" $ property $ (same_offsets :: C17 -> Expectation)+ it "C18" $ property $ (same_offsets :: C18 -> Expectation)+ it "C19" $ property $ (same_offsets :: C19 -> Expectation)+ it "C20" $ property $ (same_offsets :: C20 -> Expectation)+ describe "Test for same fields" $ do+ it "C0" $ property $ (same_fields :: C0 -> Expectation)+ it "C1" $ property $ (same_fields :: C1 -> Expectation)+ it "C2" $ property $ (same_fields :: C2 -> Expectation)+ it "C3" $ property $ (same_fields :: C3 -> Expectation)+ it "C4" $ property $ (same_fields :: C4 -> Expectation)+ it "C5" $ property $ (same_fields :: C5 -> Expectation)+ it "C6" $ property $ (same_fields :: C6 -> Expectation)+ it "C7" $ property $ (same_fields :: C7 -> Expectation)+ it "C8" $ property $ (same_fields :: C8 -> Expectation)+ it "C9" $ property $ (same_fields :: C9 -> Expectation)+ it "C10" $ property $ (same_fields :: C10 -> Expectation)+ it "C11" $ property $ (same_fields :: C11 -> Expectation)+ it "C12" $ property $ (same_fields :: C12 -> Expectation)+ it "C13" $ property $ (same_fields :: C13 -> Expectation)+ it "C14" $ property $ (same_fields :: C14 -> Expectation)+ it "C15" $ property $ (same_fields :: C15 -> Expectation)+ it "C16" $ property $ (same_fields :: C16 -> Expectation)+ it "C17" $ property $ (same_fields :: C17 -> Expectation)+ 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
+ test/Basic/TestCases.hs view
@@ -0,0 +1,797 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} +{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v2 #-} +module TestCases where++import GHC.Generics hiding (C1,S1)+import GHC.TypeLits +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+++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+ checkFields ptr1 ptr2 = (==1) <$> checkFieldsC0 ptr1 ptr2+ checkOffsets _ offs = (==1) <$> checkOffsetsC0 offs+ getSize a = fromIntegral <$> getSizeC0+ getAlignment a = fromIntegral <$> getAlignmentC0+ new (C0 ) = do+ ptr <- newC0 + return ptr++instance Arbitrary C0 where + arbitrary = return C0++foreign import ccall newC0 :: IO (Ptr C0)+foreign import ccall checkFieldsC0 :: Ptr C0 -> Ptr C0 -> IO Int8+foreign import ccall checkOffsetsC0 :: Ptr Int16 -> IO Int8+foreign import ccall getSizeC0 :: IO Int16+foreign import ccall getAlignmentC0 :: IO Int16++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 C0 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 d) = do+ ptr_b <- newStorable b+ ptr <- newC2 a ptr_b c d+ free ptr_b+ return ptr++instance Arbitrary C2 where + arbitrary = C2 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC2 :: Int32 -> Ptr C0 -> 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 C0 C0 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 f g) = do+ ptr_a <- newStorable a+ ptr_b <- newStorable b+ ptr <- newC5 ptr_a ptr_b c d e f g+ free ptr_a+ free ptr_b+ return ptr++instance Arbitrary C5 where + arbitrary = C5 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC5 :: Ptr C0 -> Ptr C0 -> 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 C0 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 e) = do+ ptr_a <- newStorable a+ ptr_b <- newStorable b+ ptr_c <- newStorable c+ ptr_d <- newStorable d+ ptr_e <- newStorable e+ ptr <- newC13 ptr_a ptr_b ptr_c ptr_d ptr_e+ free ptr_a+ free ptr_b+ free ptr_c+ free ptr_d+ free ptr_e+ return ptr++instance Arbitrary C13 where + arbitrary = C13 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC13 :: Ptr C12 -> Ptr C12 -> Ptr C0 -> 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 C0 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 d) = do+ ptr_a <- newStorable a+ ptr_b <- newStorable b+ ptr_c <- newStorable c+ ptr_d <- newStorable d+ ptr <- newC16 ptr_a ptr_b ptr_c ptr_d+ free ptr_a+ free ptr_b+ free ptr_c+ free ptr_d+ return ptr++instance Arbitrary C16 where + arbitrary = C16 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++foreign import ccall newC16 :: Ptr C10 -> Ptr C0 -> 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++#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
+ test/Basic/cbits/TestCases.c view
@@ -0,0 +1,1507 @@+#include <stddef.h>+#include <stdio.h>+#include <stdalign.h>+#include <stdlib.h>+#include "HsFFI.h"+typedef struct C0{+} C0;++C0 * newC0(){+ C0 * ret = (C0*) malloc(sizeof(C0));+ return ret;+}++void pokeC0(C0* val){+}++int checkOffsetsC0(HsInt16 *offs){+ return 1;+}++int checkFieldsC0(C0* s1, C0* s2){+ return 1; +}++HsInt16 getSizeC0() {+ return sizeof(C0);+}++HsInt16 getAlignmentC0() {+ return alignof(C0);+}++typedef struct C1{+ HsInt32 a;+ HsInt32 b;+} C1;++C1 * newC1(HsInt32 a, HsInt32 b){+ C1 * ret = (C1*) malloc(sizeof(C1));+ ret->a = a;+ ret->b = b;+ return ret;+}++void pokeC1(C1* val, HsInt32 a, HsInt32 b){+ val->a = a;+ val->b = b;+}++int checkOffsetsC1(HsInt16 *offs){+ int a = offsetof(C1, a) == offs[0];+ int b = offsetof(C1, b) == offs[1];+ return a && b;+}++int checkFieldsC1(C1* s1, C1* s2){+ int a = s1->a == s2->a;+ int b = s1->b == s2->b;+ return a && b;+}++HsInt16 getSizeC1() {+ return sizeof(C1);+}++HsInt16 getAlignmentC1() {+ return alignof(C1);+}++typedef struct C2{+ HsInt32 a;+ C0 b;+ HsInt16 c;+ HsInt8 d;+} C2;++C2 * newC2(HsInt32 a, C0* b, HsInt16 c, HsInt8 d){+ C2 * ret = (C2*) malloc(sizeof(C2));+ ret->a = a;+ ret->b = *b;+ ret->c = c;+ ret->d = d;+ return ret;+}++void pokeC2(C2* val, HsInt32 a, C0* b, HsInt16 c, HsInt8 d){+ val->a = a;+ val->b = *b;+ val->c = c;+ val->d = d;+}++int checkOffsetsC2(HsInt16 *offs){+ int a = offsetof(C2, a) == offs[0];+ int b = offsetof(C2, b) == offs[1];+ int c = offsetof(C2, c) == offs[2];+ int d = offsetof(C2, d) == offs[3];+ return a && b && c && d;+}++int checkFieldsC2(C2* s1, C2* s2){+ int a = s1->a == s2->a;+ int b = checkFieldsC0(&(s1->b),&(s2->b));+ int c = s1->c == s2->c;+ int d = s1->d == s2->d;+ return a && b && c && d;+}++HsInt16 getSizeC2() {+ return sizeof(C2);+}++HsInt16 getAlignmentC2() {+ return alignof(C2);+}++typedef struct C3{+ HsInt32 a;+ HsInt8 b;+ HsInt16 c;+} C3;++C3 * newC3(HsInt32 a, HsInt8 b, HsInt16 c){+ C3 * ret = (C3*) malloc(sizeof(C3));+ ret->a = a;+ ret->b = b;+ ret->c = c;+ return ret;+}++void pokeC3(C3* val, HsInt32 a, HsInt8 b, HsInt16 c){+ val->a = a;+ val->b = b;+ val->c = c;+}++int checkOffsetsC3(HsInt16 *offs){+ int a = offsetof(C3, a) == offs[0];+ int b = offsetof(C3, b) == offs[1];+ int c = offsetof(C3, c) == offs[2];+ return a && b && c;+}++int checkFieldsC3(C3* s1, C3* s2){+ int a = s1->a == s2->a;+ int b = s1->b == s2->b;+ int c = s1->c == s2->c;+ return a && b && c;+}++HsInt16 getSizeC3() {+ return sizeof(C3);+}++HsInt16 getAlignmentC3() {+ return alignof(C3);+}++typedef struct C4{+ HsInt32 a;+ HsInt8 b;+ HsInt8 c;+} C4;++C4 * newC4(HsInt32 a, HsInt8 b, HsInt8 c){+ C4 * ret = (C4*) malloc(sizeof(C4));+ ret->a = a;+ ret->b = b;+ ret->c = c;+ return ret;+}++void pokeC4(C4* val, HsInt32 a, HsInt8 b, HsInt8 c){+ val->a = a;+ val->b = b;+ val->c = c;+}++int checkOffsetsC4(HsInt16 *offs){+ int a = offsetof(C4, a) == offs[0];+ int b = offsetof(C4, b) == offs[1];+ int c = offsetof(C4, c) == offs[2];+ return a && b && c;+}++int checkFieldsC4(C4* s1, C4* s2){+ int a = s1->a == s2->a;+ int b = s1->b == s2->b;+ int c = s1->c == s2->c;+ return a && b && c;+}++HsInt16 getSizeC4() {+ return sizeof(C4);+}++HsInt16 getAlignmentC4() {+ return alignof(C4);+}++typedef struct C5{+ C0 a;+ C0 b;+ HsInt32 c;+ HsInt16 d;+ HsInt8 e;+ HsInt8 f;+ HsInt8 g;+} C5;++C5 * newC5(C0* a, C0* b, HsInt32 c, HsInt16 d, HsInt8 e, HsInt8 f, HsInt8 g){+ C5 * ret = (C5*) malloc(sizeof(C5));+ ret->a = *a;+ ret->b = *b;+ ret->c = c;+ ret->d = d;+ ret->e = e;+ ret->f = f;+ ret->g = g;+ return ret;+}++void pokeC5(C5* val, C0* a, C0* b, HsInt32 c, HsInt16 d, HsInt8 e, HsInt8 f, HsInt8 g){+ val->a = *a;+ val->b = *b;+ val->c = c;+ val->d = d;+ val->e = e;+ val->f = f;+ val->g = g;+}++int checkOffsetsC5(HsInt16 *offs){+ int a = offsetof(C5, a) == offs[0];+ int b = offsetof(C5, b) == offs[1];+ int c = offsetof(C5, c) == offs[2];+ int d = offsetof(C5, d) == offs[3];+ int e = offsetof(C5, e) == offs[4];+ int f = offsetof(C5, f) == offs[5];+ int g = offsetof(C5, g) == offs[6];+ return a && b && c && d && e && f && g;+}++int checkFieldsC5(C5* s1, C5* s2){+ int a = checkFieldsC0(&(s1->a),&(s2->a));+ int b = checkFieldsC0(&(s1->b),&(s2->b));+ int c = s1->c == s2->c;+ int d = s1->d == s2->d;+ int e = s1->e == s2->e;+ int f = s1->f == s2->f;+ int g = s1->g == s2->g;+ return a && b && c && d && e && f && g;+}++HsInt16 getSizeC5() {+ return sizeof(C5);+}++HsInt16 getAlignmentC5() {+ return alignof(C5);+}++typedef struct C6{+ HsInt64 a;+ HsInt8 b;+ HsInt64 c;+} C6;++C6 * newC6(HsInt64 a, HsInt8 b, HsInt64 c){+ C6 * ret = (C6*) malloc(sizeof(C6));+ ret->a = a;+ ret->b = b;+ ret->c = c;+ return ret;+}++void pokeC6(C6* val, HsInt64 a, HsInt8 b, HsInt64 c){+ val->a = a;+ val->b = b;+ val->c = c;+}++int checkOffsetsC6(HsInt16 *offs){+ int a = offsetof(C6, a) == offs[0];+ int b = offsetof(C6, b) == offs[1];+ int c = offsetof(C6, c) == offs[2];+ return a && b && c;+}++int checkFieldsC6(C6* s1, C6* s2){+ int a = s1->a == s2->a;+ int b = s1->b == s2->b;+ int c = s1->c == s2->c;+ return a && b && c;+}++HsInt16 getSizeC6() {+ return sizeof(C6);+}++HsInt16 getAlignmentC6() {+ return alignof(C6);+}++typedef struct C7{+ C1 a;+ HsInt32 b;+} C7;++C7 * newC7(C1* a, HsInt32 b){+ C7 * ret = (C7*) malloc(sizeof(C7));+ ret->a = *a;+ ret->b = b;+ return ret;+}++void pokeC7(C7* val, C1* a, HsInt32 b){+ val->a = *a;+ val->b = b;+}++int checkOffsetsC7(HsInt16 *offs){+ int a = offsetof(C7, a) == offs[0];+ int b = offsetof(C7, b) == offs[1];+ return a && b;+}++int checkFieldsC7(C7* s1, C7* s2){+ int a = checkFieldsC1(&(s1->a),&(s2->a));+ int b = s1->b == s2->b;+ return a && b;+}++HsInt16 getSizeC7() {+ return sizeof(C7);+}++HsInt16 getAlignmentC7() {+ return alignof(C7);+}++typedef struct C8{+ C2 a;+ HsInt8 b;+ C4 c;+} C8;++C8 * newC8(C2* a, HsInt8 b, C4* c){+ C8 * ret = (C8*) malloc(sizeof(C8));+ ret->a = *a;+ ret->b = b;+ ret->c = *c;+ return ret;+}++void pokeC8(C8* val, C2* a, HsInt8 b, C4* c){+ val->a = *a;+ val->b = b;+ val->c = *c;+}++int checkOffsetsC8(HsInt16 *offs){+ int a = offsetof(C8, a) == offs[0];+ int b = offsetof(C8, b) == offs[1];+ int c = offsetof(C8, c) == offs[2];+ return a && b && c;+}++int checkFieldsC8(C8* s1, C8* s2){+ int a = checkFieldsC2(&(s1->a),&(s2->a));+ int b = s1->b == s2->b;+ int c = checkFieldsC4(&(s1->c),&(s2->c));+ return a && b && c;+}++HsInt16 getSizeC8() {+ return sizeof(C8);+}++HsInt16 getAlignmentC8() {+ return alignof(C8);+}++typedef struct C9{+ C5 a;+ HsInt8 b;+ HsInt8 c;+ HsInt8 d;+} C9;++C9 * newC9(C5* a, HsInt8 b, HsInt8 c, HsInt8 d){+ C9 * ret = (C9*) malloc(sizeof(C9));+ ret->a = *a;+ ret->b = b;+ ret->c = c;+ ret->d = d;+ return ret;+}++void pokeC9(C9* val, C5* a, HsInt8 b, HsInt8 c, HsInt8 d){+ val->a = *a;+ val->b = b;+ val->c = c;+ val->d = d;+}++int checkOffsetsC9(HsInt16 *offs){+ int a = offsetof(C9, a) == offs[0];+ int b = offsetof(C9, b) == offs[1];+ int c = offsetof(C9, c) == offs[2];+ int d = offsetof(C9, d) == offs[3];+ return a && b && c && d;+}++int checkFieldsC9(C9* s1, C9* s2){+ int a = checkFieldsC5(&(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;+}++HsInt16 getSizeC9() {+ return sizeof(C9);+}++HsInt16 getAlignmentC9() {+ return alignof(C9);+}++typedef struct C10{+ C8 a;+ HsInt64 b;+ C1 c;+} C10;++C10 * newC10(C8* a, HsInt64 b, C1* c){+ C10 * ret = (C10*) malloc(sizeof(C10));+ ret->a = *a;+ ret->b = b;+ ret->c = *c;+ return ret;+}++void pokeC10(C10* val, C8* a, HsInt64 b, C1* c){+ val->a = *a;+ val->b = b;+ val->c = *c;+}++int checkOffsetsC10(HsInt16 *offs){+ int a = offsetof(C10, a) == offs[0];+ int b = offsetof(C10, b) == offs[1];+ int c = offsetof(C10, c) == offs[2];+ return a && b && c;+}++int checkFieldsC10(C10* s1, C10* s2){+ int a = checkFieldsC8(&(s1->a),&(s2->a));+ int b = s1->b == s2->b;+ int c = checkFieldsC1(&(s1->c),&(s2->c));+ return a && b && c;+}++HsInt16 getSizeC10() {+ return sizeof(C10);+}++HsInt16 getAlignmentC10() {+ return alignof(C10);+}++typedef struct C11{+ C10 a;+ C10 b;+} C11;++C11 * newC11(C10* a, C10* b){+ C11 * ret = (C11*) malloc(sizeof(C11));+ ret->a = *a;+ ret->b = *b;+ return ret;+}++void pokeC11(C11* val, C10* a, C10* b){+ val->a = *a;+ val->b = *b;+}++int checkOffsetsC11(HsInt16 *offs){+ int a = offsetof(C11, a) == offs[0];+ int b = offsetof(C11, b) == offs[1];+ return a && b;+}++int checkFieldsC11(C11* s1, C11* s2){+ int a = checkFieldsC10(&(s1->a),&(s2->a));+ int b = checkFieldsC10(&(s1->b),&(s2->b));+ return a && b;+}++HsInt16 getSizeC11() {+ return sizeof(C11);+}++HsInt16 getAlignmentC11() {+ return alignof(C11);+}++typedef struct C12{+ HsInt64 a;+ HsInt64 b;+ HsInt64 c;+ HsInt64 d;+} C12;++C12 * newC12(HsInt64 a, HsInt64 b, HsInt64 c, HsInt64 d){+ C12 * ret = (C12*) malloc(sizeof(C12));+ ret->a = a;+ ret->b = b;+ ret->c = c;+ ret->d = d;+ return ret;+}++void pokeC12(C12* val, HsInt64 a, HsInt64 b, HsInt64 c, HsInt64 d){+ val->a = a;+ val->b = b;+ val->c = c;+ val->d = d;+}++int checkOffsetsC12(HsInt16 *offs){+ int a = offsetof(C12, a) == offs[0];+ int b = offsetof(C12, b) == offs[1];+ int c = offsetof(C12, c) == offs[2];+ int d = offsetof(C12, d) == offs[3];+ return a && b && c && d;+}++int checkFieldsC12(C12* s1, C12* 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;+}++HsInt16 getSizeC12() {+ return sizeof(C12);+}++HsInt16 getAlignmentC12() {+ return alignof(C12);+}++typedef struct C13{+ C12 a;+ C12 b;+ C0 c;+ C12 d;+ C12 e;+} C13;++C13 * newC13(C12* a, C12* b, C0* c, C12* d, C12* e){+ C13 * ret = (C13*) malloc(sizeof(C13));+ ret->a = *a;+ ret->b = *b;+ ret->c = *c;+ ret->d = *d;+ ret->e = *e;+ return ret;+}++void pokeC13(C13* val, C12* a, C12* b, C0* c, C12* d, C12* e){+ val->a = *a;+ val->b = *b;+ val->c = *c;+ val->d = *d;+ val->e = *e;+}++int checkOffsetsC13(HsInt16 *offs){+ int a = offsetof(C13, a) == offs[0];+ int b = offsetof(C13, b) == offs[1];+ int c = offsetof(C13, c) == offs[2];+ int d = offsetof(C13, d) == offs[3];+ int e = offsetof(C13, e) == offs[4];+ return a && b && c && d && e;+}++int checkFieldsC13(C13* s1, C13* s2){+ int a = checkFieldsC12(&(s1->a),&(s2->a));+ int b = checkFieldsC12(&(s1->b),&(s2->b));+ int c = checkFieldsC0(&(s1->c),&(s2->c));+ int d = checkFieldsC12(&(s1->d),&(s2->d));+ int e = checkFieldsC12(&(s1->e),&(s2->e));+ return a && b && c && d && e;+}++HsInt16 getSizeC13() {+ return sizeof(C13);+}++HsInt16 getAlignmentC13() {+ return alignof(C13);+}++typedef struct C14{+ C13 a;+ C13 b;+ C13 c;+ C13 d;+ HsInt8 e;+} C14;++C14 * newC14(C13* a, C13* b, C13* c, C13* d, HsInt8 e){+ C14 * ret = (C14*) malloc(sizeof(C14));+ ret->a = *a;+ ret->b = *b;+ ret->c = *c;+ ret->d = *d;+ ret->e = e;+ return ret;+}++void pokeC14(C14* val, C13* a, C13* b, C13* c, C13* d, HsInt8 e){+ val->a = *a;+ val->b = *b;+ val->c = *c;+ val->d = *d;+ val->e = e;+}++int checkOffsetsC14(HsInt16 *offs){+ int a = offsetof(C14, a) == offs[0];+ int b = offsetof(C14, b) == offs[1];+ int c = offsetof(C14, c) == offs[2];+ int d = offsetof(C14, d) == offs[3];+ int e = offsetof(C14, e) == offs[4];+ return a && b && c && d && e;+}++int checkFieldsC14(C14* s1, C14* s2){+ int a = checkFieldsC13(&(s1->a),&(s2->a));+ int b = checkFieldsC13(&(s1->b),&(s2->b));+ int c = checkFieldsC13(&(s1->c),&(s2->c));+ int d = checkFieldsC13(&(s1->d),&(s2->d));+ int e = s1->e == s2->e;+ return a && b && c && d && e;+}++HsInt16 getSizeC14() {+ return sizeof(C14);+}++HsInt16 getAlignmentC14() {+ return alignof(C14);+}++typedef struct C15{+ C12 a;+ C14 b;+} C15;++C15 * newC15(C12* a, C14* b){+ C15 * ret = (C15*) malloc(sizeof(C15));+ ret->a = *a;+ ret->b = *b;+ return ret;+}++void pokeC15(C15* val, C12* a, C14* b){+ val->a = *a;+ val->b = *b;+}++int checkOffsetsC15(HsInt16 *offs){+ int a = offsetof(C15, a) == offs[0];+ int b = offsetof(C15, b) == offs[1];+ return a && b;+}++int checkFieldsC15(C15* s1, C15* s2){+ int a = checkFieldsC12(&(s1->a),&(s2->a));+ int b = checkFieldsC14(&(s1->b),&(s2->b));+ return a && b;+}++HsInt16 getSizeC15() {+ return sizeof(C15);+}++HsInt16 getAlignmentC15() {+ return alignof(C15);+}++typedef struct C16{+ C10 a;+ C0 b;+ C15 c;+ C7 d;+} C16;++C16 * newC16(C10* a, C0* b, C15* c, C7* d){+ C16 * ret = (C16*) malloc(sizeof(C16));+ ret->a = *a;+ ret->b = *b;+ ret->c = *c;+ ret->d = *d;+ return ret;+}++void pokeC16(C16* val, C10* a, C0* b, C15* c, C7* d){+ val->a = *a;+ val->b = *b;+ val->c = *c;+ val->d = *d;+}++int checkOffsetsC16(HsInt16 *offs){+ int a = offsetof(C16, a) == offs[0];+ int b = offsetof(C16, b) == offs[1];+ int c = offsetof(C16, c) == offs[2];+ int d = offsetof(C16, d) == offs[3];+ return a && b && c && d;+}++int checkFieldsC16(C16* s1, C16* s2){+ int a = checkFieldsC10(&(s1->a),&(s2->a));+ int b = checkFieldsC0(&(s1->b),&(s2->b));+ int c = checkFieldsC15(&(s1->c),&(s2->c));+ int d = checkFieldsC7(&(s1->d),&(s2->d));+ return a && b && c && d;+}++HsInt16 getSizeC16() {+ return sizeof(C16);+}++HsInt16 getAlignmentC16() {+ return alignof(C16);+}++typedef struct C17{+ HsFloat a;+ HsDouble b;+ HsFloat c;+} C17;++C17 * newC17(HsFloat a, HsDouble b, HsFloat c){+ C17 * ret = (C17*) malloc(sizeof(C17));+ ret->a = a;+ ret->b = b;+ ret->c = c;+ return ret;+}++void pokeC17(C17* val, HsFloat a, HsDouble b, HsFloat c){+ val->a = a;+ val->b = b;+ val->c = c;+}++int checkOffsetsC17(HsInt16 *offs){+ int a = offsetof(C17, a) == offs[0];+ int b = offsetof(C17, b) == offs[1];+ int c = offsetof(C17, c) == offs[2];+ return a && b && c;+}++int checkFieldsC17(C17* s1, C17* s2){+ int a = s1->a == s2->a;+ int b = s1->b == s2->b;+ int c = s1->c == s2->c;+ return a && b && c;+}++HsInt16 getSizeC17() {+ return sizeof(C17);+}++HsInt16 getAlignmentC17() {+ return alignof(C17);+}++typedef struct C18{+ HsFloat a;+ HsFloat b;+ HsDouble c;+ HsFloat d;+} C18;++C18 * newC18(HsFloat a, HsFloat b, HsDouble c, HsFloat d){+ C18 * ret = (C18*) malloc(sizeof(C18));+ ret->a = a;+ ret->b = b;+ ret->c = c;+ ret->d = d;+ return ret;+}++void pokeC18(C18* val, HsFloat a, HsFloat b, HsDouble c, HsFloat d){+ val->a = a;+ val->b = b;+ val->c = c;+ val->d = d;+}++int checkOffsetsC18(HsInt16 *offs){+ int a = offsetof(C18, a) == offs[0];+ int b = offsetof(C18, b) == offs[1];+ int c = offsetof(C18, c) == offs[2];+ int d = offsetof(C18, d) == offs[3];+ return a && b && c && d;+}++int checkFieldsC18(C18* s1, C18* 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;+}++HsInt16 getSizeC18() {+ return sizeof(C18);+}++HsInt16 getAlignmentC18() {+ return alignof(C18);+}++typedef struct C19{+ C17 a;+ HsFloat b;+ HsDouble c;+} C19;++C19 * newC19(C17* a, HsFloat b, HsDouble c){+ C19 * ret = (C19*) malloc(sizeof(C19));+ ret->a = *a;+ ret->b = b;+ ret->c = c;+ return ret;+}++void pokeC19(C19* val, C17* a, HsFloat b, HsDouble c){+ val->a = *a;+ val->b = b;+ val->c = c;+}++int checkOffsetsC19(HsInt16 *offs){+ int a = offsetof(C19, a) == offs[0];+ int b = offsetof(C19, b) == offs[1];+ int c = offsetof(C19, c) == offs[2];+ return a && b && c;+}++int checkFieldsC19(C19* s1, C19* s2){+ int a = checkFieldsC17(&(s1->a),&(s2->a));+ int b = s1->b == s2->b;+ int c = s1->c == s2->c;+ return a && b && c;+}++HsInt16 getSizeC19() {+ return sizeof(C19);+}++HsInt16 getAlignmentC19() {+ return alignof(C19);+}++typedef struct C20{+ HsDouble a;+ C18 b;+ HsDouble c;+ C19 d;+} C20;++C20 * newC20(HsDouble a, C18* b, HsDouble c, C19* d){+ C20 * ret = (C20*) malloc(sizeof(C20));+ ret->a = a;+ ret->b = *b;+ ret->c = c;+ ret->d = *d;+ return ret;+}++void pokeC20(C20* val, HsDouble a, C18* b, HsDouble c, C19* d){+ val->a = a;+ val->b = *b;+ val->c = c;+ val->d = *d;+}++int checkOffsetsC20(HsInt16 *offs){+ int a = offsetof(C20, a) == offs[0];+ int b = offsetof(C20, b) == offs[1];+ int c = offsetof(C20, c) == offs[2];+ int d = offsetof(C20, d) == offs[3];+ return a && b && c && d;+}++int checkFieldsC20(C20* s1, C20* s2){+ int a = s1->a == s2->a;+ int b = checkFieldsC18(&(s1->b),&(s2->b));+ int c = s1->c == s2->c;+ int d = checkFieldsC19(&(s1->d),&(s2->d));+ return a && b && c && d;+}++HsInt16 getSizeC20() {+ return sizeof(C20);+}++HsInt16 getAlignmentC20() {+ 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);+}+
− test/ids/Concrete/Instances.hs
@@ -1,10 +0,0 @@-{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}-{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} -module Instances where--import Types-import Foreign.Storable.Generic--instance GStorable Flat-instance GStorable Nested-instance GStorable Nested2
− test/ids/Concrete/Main.hs
@@ -1,7 +0,0 @@-module Main where--import Types-import Instances--main :: IO ()-main = return ()
− test/ids/Concrete/Types.hs
@@ -1,9 +0,0 @@-{-#LANGUAGE DeriveGeneric #-}--module Types where--import GHC.Generics--data Flat = Flat Int Double deriving (Generic)-data Nested = Nested Flat deriving (Generic)-data Nested2 = Nested2 Nested deriving (Generic)
− test/ids/Handwritten/Instances.hs
@@ -1,38 +0,0 @@-{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}-{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} --module Instances where--import Types-import Foreign.Storable.Generic---instance GStorable Flat where- gsizeOf _ = 16- galignment _ = 8- gpeekByteOff ptr offset = Flat - <$> gpeekByteOff ptr offset- <*> gpeekByteOff ptr (offset+8)- gpokeByteOff ptr offset (Flat a b) = - gpokeByteOff ptr offset a- >> gpokeByteOff ptr (offset+8) b--instance GStorable Nested where - gsizeOf _ = 16- galignment _ = 8- gpeekByteOff ptr offset = Nested <$> (Flat - <$> gpeekByteOff ptr offset- <*> gpeekByteOff ptr (offset+8))- gpokeByteOff ptr offset (Nested (Flat a b)) = - gpokeByteOff ptr offset a- >> gpokeByteOff ptr (offset+8) b--instance GStorable Nested2 where- gsizeOf _ = 16- galignment _ = 8- gpeekByteOff ptr offset = Nested2 <$> (Nested <$> (Flat - <$> gpeekByteOff ptr offset- <*> gpeekByteOff ptr (offset+8)))- gpokeByteOff ptr offset (Nested2 (Nested (Flat a b))) = - gpokeByteOff ptr offset a- >> gpokeByteOff ptr (offset+8) b
− test/ids/Handwritten/Main.hs
@@ -1,7 +0,0 @@-module Main where--import Types-import Instances--main :: IO ()-main = return ()
− test/ids/Handwritten/Types.hs
@@ -1,9 +0,0 @@-{-#LANGUAGE DeriveGeneric #-}--module Types where--import GHC.Generics--data Flat = Flat Int Double deriving (Generic)-data Nested = Nested Flat deriving (Generic)-data Nested2 = Nested2 Nested deriving (Generic)
− test/ids/NewType/Instances.hs
@@ -1,11 +0,0 @@-{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}-{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} --module Instances where--import Types-import Foreign.Storable.Generic--instance GStorable NFlat-instance GStorable NNested-instance GStorable NNested2
− test/ids/NewType/Main.hs
@@ -1,7 +0,0 @@-module Main where--import Types-import Instances--main :: IO ()-main = return ()
− test/ids/NewType/Types.hs
@@ -1,16 +0,0 @@-{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}--module Types where--import GHC.Generics-import Foreign.Storable.Generic--data Flat = Flat Int Double deriving (Generic, GStorable)-data Nested = Nested Flat deriving (Generic, GStorable) -data Nested2 = Nested2 Nested deriving (Generic, GStorable)--newtype NFlat = NFlat Flat deriving (Generic)-newtype NNested = NNested Nested deriving (Generic)-newtype NNested2 = NNested2 Nested2 deriving (Generic)-
− test/ids/ParametrisedSpec/Instances.hs
@@ -1,21 +0,0 @@-{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}-{-# LANGUAGE FlexibleInstances #-}-module Instances where--import Types-import Foreign.Storable.Generic-import Foreign.Ptr --instance (GStorable a, GStorable b) => GStorable (Flat a b) where {- {-# SPECIALIZE instance GStorable (Flat Int Double) #-};- {-# SPECIALIZE instance GStorable (Flat Float Double) #-}-}-instance (GStorable a, GStorable b) => GStorable (Nested a b) where {- {-# SPECIALIZE instance GStorable (Nested Int Double) #-};- {-# SPECIALIZE instance GStorable (Nested Word Char) #-}-}-instance (GStorable a, GStorable b) => GStorable (Nested2 a b) where {- {-# SPECIALIZE instance GStorable (Nested2 Int Double) #-};- {-# SPECIALIZE instance GStorable (Nested2 Float Float) #-}-}---instance (GStorable a, GStorable b) => GStorable (Nested2 a b)
− test/ids/ParametrisedSpec/Main.hs
@@ -1,10 +0,0 @@-module Main where--import Types-import Instances-import Usage --import Foreign.Ptr--main :: IO ()-main = flatPeekByteOff nullPtr 0 >> return ()
− test/ids/ParametrisedSpec/Types.hs
@@ -1,9 +0,0 @@-{-#LANGUAGE DeriveGeneric #-}--module Types where--import GHC.Generics--data Flat a b = Flat a b deriving (Generic)-data Nested a b = Nested a (Flat a b) deriving (Generic)-data Nested2 a b = Nested2 b (Nested a b) deriving (Generic)
− test/ids/ParametrisedSpec/Usage.hs
@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}-module Usage where--import Types-import Instances--import Foreign.Storable.Generic-import Foreign.Ptr-import Foreign.Marshal.Alloc--import GHC.Exts-------------- Flat ---------------flatSizeOf :: Flat Int Double -> Int-flatSizeOf = gsizeOf--flatAlignment :: Flat Int Double -> Int-flatAlignment = galignment---flatPeekByteOff :: Ptr b -> Int -> IO (Flat Int Double)-flatPeekByteOff = gpeekByteOff------ flatPokeByteOff :: Ptr b -> Int -> Flat Int Double -> IO ()--- flatPokeByteOff = gpokeByteOff----- --------------- -- Nested ----- --------------- --- nestedSizeOf :: Nested Int Double -> Int--- nestedSizeOf = gsizeOf--- --- nestedAlignment :: Nested Int Double -> Int--- nestedAlignment = galignment--- --- nestedPeekByteOff :: Ptr b -> Int -> IO (Nested Int Double)--- nestedPeekByteOff = gpeekByteOff--- --- -- nestedPokeByteOff :: Ptr b -> Int -> Nested Int Double -> IO ()--- -- nestedPokeByteOff = gpokeByteOff--- --- ----------------- -- Nested 2 ----- ----------------- --- nested2SizeOf :: Nested2 Int Double -> Int--- nested2SizeOf = gsizeOf--- --- nested2Alignment :: Nested2 Int Double -> Int--- nested2Alignment = galignment--- --- nested2PeekByteOff :: Ptr b -> Int -> IO (Nested2 Int Double)--- nested2PeekByteOff = gpeekByteOff--- --- -- nested2PokeByteOff :: Ptr b -> Int -> Nested2 Int Double -> IO ()--- -- nested2PokeByteOff = gpokeByteOff
− test/ids/TypeSynonym/Instances.hs
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}-{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} --{-# LANGUAGE FlexibleInstances #-}-module Instances where--import Types-import Foreign.Storable.Generic--instance GStorable Flat -instance GStorable Flat2-instance GStorable Nested -instance GStorable Nested2
− test/ids/TypeSynonym/Main.hs
@@ -1,7 +0,0 @@-module Main where--import Types-import Instances--main :: IO ()-main = return ()
− test/ids/TypeSynonym/Types.hs
@@ -1,14 +0,0 @@-{-#LANGUAGE DeriveGeneric #-}--module Types where--import GHC.Generics--data Flat = Flat Int Double deriving (Generic)-data Flat2 = Flat2 Double Char deriving (Generic)-data Nested = Nested Flat Flat2 deriving (Generic)-data Nested2 = Nested2 Nested deriving (Generic)--type TFlat = Flat -type TNested = Nested -type TNested2 = Nested2