diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -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 ] ] ] diff --git a/benchmark/TestCases.hs b/benchmark/TestCases.hs --- a/benchmark/TestCases.hs +++ b/benchmark/TestCases.hs @@ -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 diff --git a/benchmark/TestCasesOptimized.hs b/benchmark/TestCasesOptimized.hs --- a/benchmark/TestCasesOptimized.hs +++ b/benchmark/TestCasesOptimized.hs @@ -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 diff --git a/derive-storable-plugin.cabal b/derive-storable-plugin.cabal --- a/derive-storable-plugin.cabal +++ b/derive-storable-plugin.cabal @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin.hs b/src/Foreign/Storable/Generic/Plugin.hs --- a/src/Foreign/Storable/Generic/Plugin.hs +++ b/src/Foreign/Storable/Generic/Plugin.hs @@ -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) diff --git a/src/Foreign/Storable/Generic/Plugin/Internal.hs b/src/Foreign/Storable/Generic/Plugin/Internal.hs --- a/src/Foreign/Storable/Generic/Plugin/Internal.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal.hs @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs --- a/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Error.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Error.hs --- a/src/Foreign/Storable/Generic/Plugin/Internal/Error.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Error.hs @@ -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" diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs --- a/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs @@ -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 + diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs --- a/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs @@ -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 -- diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs --- a/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs @@ -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 diff --git a/test/Basic/MemoryCSpec.hs b/test/Basic/MemoryCSpec.hs new file mode 100644 --- /dev/null +++ b/test/Basic/MemoryCSpec.hs @@ -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 diff --git a/test/Basic/TestCases.hs b/test/Basic/TestCases.hs new file mode 100644 --- /dev/null +++ b/test/Basic/TestCases.hs @@ -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 diff --git a/test/Basic/cbits/TestCases.c b/test/Basic/cbits/TestCases.c new file mode 100644 --- /dev/null +++ b/test/Basic/cbits/TestCases.c @@ -0,0 +1,1507 @@ +#include +#include +#include +#include +#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); +} + diff --git a/test/ids/Concrete/Instances.hs b/test/ids/Concrete/Instances.hs deleted file mode 100644 --- a/test/ids/Concrete/Instances.hs +++ /dev/null @@ -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 diff --git a/test/ids/Concrete/Main.hs b/test/ids/Concrete/Main.hs deleted file mode 100644 --- a/test/ids/Concrete/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Types -import Instances - -main :: IO () -main = return () diff --git a/test/ids/Concrete/Types.hs b/test/ids/Concrete/Types.hs deleted file mode 100644 --- a/test/ids/Concrete/Types.hs +++ /dev/null @@ -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) diff --git a/test/ids/Handwritten/Instances.hs b/test/ids/Handwritten/Instances.hs deleted file mode 100644 --- a/test/ids/Handwritten/Instances.hs +++ /dev/null @@ -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 diff --git a/test/ids/Handwritten/Main.hs b/test/ids/Handwritten/Main.hs deleted file mode 100644 --- a/test/ids/Handwritten/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Types -import Instances - -main :: IO () -main = return () diff --git a/test/ids/Handwritten/Types.hs b/test/ids/Handwritten/Types.hs deleted file mode 100644 --- a/test/ids/Handwritten/Types.hs +++ /dev/null @@ -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) diff --git a/test/ids/NewType/Instances.hs b/test/ids/NewType/Instances.hs deleted file mode 100644 --- a/test/ids/NewType/Instances.hs +++ /dev/null @@ -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 diff --git a/test/ids/NewType/Main.hs b/test/ids/NewType/Main.hs deleted file mode 100644 --- a/test/ids/NewType/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Types -import Instances - -main :: IO () -main = return () diff --git a/test/ids/NewType/Types.hs b/test/ids/NewType/Types.hs deleted file mode 100644 --- a/test/ids/NewType/Types.hs +++ /dev/null @@ -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) - diff --git a/test/ids/ParametrisedSpec/Instances.hs b/test/ids/ParametrisedSpec/Instances.hs deleted file mode 100644 --- a/test/ids/ParametrisedSpec/Instances.hs +++ /dev/null @@ -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) diff --git a/test/ids/ParametrisedSpec/Main.hs b/test/ids/ParametrisedSpec/Main.hs deleted file mode 100644 --- a/test/ids/ParametrisedSpec/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main where - -import Types -import Instances -import Usage - -import Foreign.Ptr - -main :: IO () -main = flatPeekByteOff nullPtr 0 >> return () diff --git a/test/ids/ParametrisedSpec/Types.hs b/test/ids/ParametrisedSpec/Types.hs deleted file mode 100644 --- a/test/ids/ParametrisedSpec/Types.hs +++ /dev/null @@ -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) diff --git a/test/ids/ParametrisedSpec/Usage.hs b/test/ids/ParametrisedSpec/Usage.hs deleted file mode 100644 --- a/test/ids/ParametrisedSpec/Usage.hs +++ /dev/null @@ -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 diff --git a/test/ids/TypeSynonym/Instances.hs b/test/ids/TypeSynonym/Instances.hs deleted file mode 100644 --- a/test/ids/TypeSynonym/Instances.hs +++ /dev/null @@ -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 diff --git a/test/ids/TypeSynonym/Main.hs b/test/ids/TypeSynonym/Main.hs deleted file mode 100644 --- a/test/ids/TypeSynonym/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Types -import Instances - -main :: IO () -main = return () diff --git a/test/ids/TypeSynonym/Types.hs b/test/ids/TypeSynonym/Types.hs deleted file mode 100644 --- a/test/ids/TypeSynonym/Types.hs +++ /dev/null @@ -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