packages feed

C-structs (empty) → 0.1.0.1

raw patch · 17 files changed

+962/−0 lines, 17 filesdep +C-structsdep +Globdep +HUnitsetup-changed

Dependencies added: C-structs, Glob, HUnit, QuickCheck, base, doctest, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

+ C-structs.cabal view
@@ -0,0 +1,78 @@+Name: C-structs+Version: 0.1.0.1+Cabal-Version: >= 1.10+License: MIT+License-file: LICENSE+Author: Simon Plakolb+Copyright: (c) 2020 Simon Plakolb+Homepage: https://github.com/pinselimo/cstructs-in-haskell+Synopsis: C-Structs implementation for Haskell+Description:+    C-structs lets you create correct C structs in Haskell.+    These can be used for FFI calls, import as well as exports.+    This package is part of the development efforts for the Python library+    Pythas. Pythas provides an interface to import Haskell modules.+    .+    Note: As of GHC 8.10 structs cannot be passed by value, only by reference.+Maintainer: s.plakolb@gmail.com+Category: foreign, c, structures, data+Build-Type: Simple+Extra-Source-Files: README.md, CHANGELOG.md, test/libs/c_test.c, test/libs/c_test.h+Tested-With: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4++Source-Repository head+    type: git+    location: https://github.com/pinselimo/cstructs-in-haskell++Library+    Exposed-Modules:+        Foreign.C.Structs+    Other-Modules:+        Foreign.C.Structs.Types,+        Foreign.C.Structs.Templates,+        Foreign.C.Structs.Utils+    Other-Extensions:+        TemplateHaskell+        CPP+    Default-Language: Haskell2010+    Build-Depends:+        base >= 3.0.0 && < 5.0.0,+        template-haskell >= 2.2 && < 2.17+    HS-Source-Dirs: src++Test-Suite unit-tests+    type: exitcode-stdio-1.0+    main-is: Main.hs+    Other-Extensions:+        ForeignFunctionInterface+        TemplateHaskell+        CPP+    Other-Modules:+        UnitTests,+        Properties,+        CTest,+        Templates+    Default-Language: Haskell2010+    hs-source-dirs: test+    include-dirs: test/libs+    includes: c_test.h+    c-sources: test/libs/c_test.c+    build-depends:+        C-structs,+        base         >= 3.0 && < 5.0,+        HUnit        >= 1.2 && < 1.7,+        QuickCheck   >= 2.3 && < 2.15,+        template-haskell >= 2.2 && < 2.17,+        test-framework  >= 0.4.1 && < 0.9,+        test-framework-hunit >= 0.2.6 && < 0.4,+        test-framework-quickcheck2 >= 0.2.8 && < 0.4++Test-Suite doctest+    type: exitcode-stdio-1.0+    main-is: DocTest.hs+    Default-Language: Haskell2010+    hs-source-dirs: test+    build-depends:+        base        >= 4.0 && < 5.0,+        doctest     >= 0.3 && < 0.18,+        Glob        >= 0.1 && < 0.11
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+v0.1.0.1: Added thorough testing and structs with up to four fields+
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020 Simon Plakolb++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,122 @@+# C-Structs in Haskell [![Build](https://secure.travis-ci.org/pinselimo/cstructs-in-haskell.svg)](https://travis-ci.org/pinselimo/cstructs-in-haskell) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/C-structs/badge)](https://matrix.hackage.haskell.org/package/C-structs) [![Hackage Version](https://img.shields.io/hackage/v/C-structs.svg?label=Hackage)](http://hackage.haskell.org/package/C-structs) [![Dependencies of latest version on Hackage](https://img.shields.io/hackage-deps/v/C-structs.svg)](https://hackage.haskell.org/package/C-structs)++C-structs lets you create dynamically typed and correctly padded C structs in Haskell.+These can be used for FFI calls, imports and exports.+This package is part of the development efforts for the Python library [```Pythas```](https://github.com/pinselimo/Pythas/).+Pythas provides an interface to import Haskell modules.++Note: As of GHC 8.10 structs cannot be passed by value, [only by reference](https://wiki.haskell.org/Foreign_Function_Interface#Foreign_types).+++## Usage++You can use these types as a classic ```hackage``` package.+The library has no other dependencies than some of the ```Foreign.*``` modules contained in ```base```.++### Basics++~~~haskell+λ> import Foreign.C.Structs+λ> s = Struct2 1 2 :: Struct2 Int Int+~~~++can be interpreted as an equivalent to:++~~~C+struct Struct2 {+    int s21st;+    int s22nd;+};++struct Struct2 s;+s.s21st = 1;+s.s22nd = 2;+~~~++or with Python's ```ctypes```:++~~~python+>>> from ctypes import Structure, c_int+>>> class Struct2( Structure ):+...     _fields_ = [("s21st", c_int), ("s22nd", c_int)]+...+>>> s = Struct2(1,2)+~~~++On memory all of these examples should have the exact same representation.+A pointer to either ```s``` can then be exchanged with the other and used in a ```foreign``` call.++### FFI usage++The following shows an example of a foreign import of a ```struct Struct2``` as defined above:++~~~C+struct Struct2 *foo (void) {+    struct Struct2 *val;+    val = malloc (sizeof (struct Struct2));+    val->s21st = 42;+    val->s22nd = 63;+    return val;+}+~~~++can be imported in a Haskell module as follows:++~~~haskell+{-# LANGUAGE ForeignFunctionInterface #-}++import Foreign.Ptr (Ptr)+import Foreign.Storable (peek)+import Foreign.Marshal.Alloc (free)+import Foreign.C.Types (CInt)+import Foreign.C.Structs (Struct2)++foreign import ccall "foo" foo :: Ptr (Struct2 CInt CInt)++main = do+    putStrLn "Reading values from C.."+    s <- peek foo+    free foo+    putStrLn "Received:"+    putStrLn $ show s+~~~++For a more elaborated usage examples checkout [```Pythas```](https://github.com/pinselimo/Pythas) in conjunction with [```Pythas-Types```](https://github.com/pinselimo/Pythas-Types).+It uses ```Foreign.C.Structs``` to declare its storage functions for ```Haskell``` tuples. In addition, its Array and Linked List instances are based on this library.++### More fields++Currently ```C-structs``` exports types featuring up to six fields. If you require more, you can easily create them using Template Haskell and the ```structT``` function:++~~~haskell+structT 8+~~~++will create:++~~~haskell+data Struct8 = Struct8+    { s81st :: a+    , s82nd :: b+    , s83rd :: c+    , s84th :: d+    , s85th :: e+    ...+    } deriving (Show, Eq)++instance Storable Struct8 ...+~~~++## Testing++Identity properties are tested with QuickCheck to ensure that peek and poke are reversible.+The result of ```sizeOf``` is dependent on the order of types. Its correctness can only be tested with HUnit.+The ```alignment``` function is trivial and only tested implicitly through ```sizeOf```.++Imports from C are tested in ```CTest.hs``` and together with the identity tests form the guarantee that also exports to C are consistent.+All tests are performed for all available GHC versions through [haskell-ci](https://github.com/haskell-CI/haskell-ci) to ensure maximum compatibility.++## License++This part of Pythas is licensed under the ```MIT``` License. Please be aware that the full ```Pythas``` package is under ```LGPLv3```. Refer to the accompanying LICENSE or COPYING files for details.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Foreign/C/Structs.hs view
@@ -0,0 +1,69 @@+{- |+Module          : Foreign.C.Structs+Description     : Create C structs from Haskell+Copyright       : (c) Simon Plakolb, 2020+License         : MIT+Maintainer      : s.plakolb@gmail.com+Stability       : beta++The @Foreign.C.Structs@ module allows you to construct C structs of arbitrary @Storable@ types.+-}+module Foreign.C.Structs (+      Struct2(..)+    , Struct3(..)+    , Struct4(..)+    , Struct5(..)+    , Struct6(..)+    , structT+    , acs+    -- Exports for Template Haskell usage+    , next, sizeof, fmax+    -- Reexports for Template Haskell+    , Storable, peek, poke, sizeOf, alignment, castPtr+    ) where+import Foreign.C.Structs.Types (+     Struct2(..)+    ,Struct3(..)+    ,Struct4(..)+    ,Struct5(..)+    ,Struct6(..)+    )++import Foreign.C.Structs.Templates (+     structT+    ,acs+    )++import Foreign.Storable (+     Storable, peek, poke, sizeOf, alignment+    )+import Foreign.Ptr (+     castPtr+    )+import Foreign.C.Structs.Utils (+     next+    ,sizeof+    ,fmax+    )++{- |+C-Structs+---------++The @Foreign.C.Structs@ module allows you to construct C structs of arbitrary @Storable@ types.+It also defined them as instances of the Storable type-class. You can thus create pointers+to an instance of such a struct and interface with another language.++Currently up to six records are supported. Each number of records needs its own type.+The types are named after the number of records they support: 'Struct2', 'Struct3' .. @StructN@++If a Struct type with more fields is required, it can be created using Template Haskell and the 'structT' function:++> structT 8 -- creates a Struct with 8 fields++Field access is provided threefold:+ * Record syntax+ * Pattern matching+ * Template Haskell 'acs' function.+-}+
+ src/Foreign/C/Structs/Templates.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+{- |+Module          : Foreign.C.Structs.Templates+Description     : Create C structs from Haskell+Copyright       : (c) Simon Plakolb, 2020+License         : MIT+Maintainer      : s.plakolb@gmail.com+Stability       : beta++This module exposes the template haskell framework to create Struct types.+-}+module Foreign.C.Structs.Templates+    (structT, acs)+where++import Language.Haskell.TH++import Foreign.Storable (Storable, peek, poke, sizeOf, alignment)+import Foreign.Ptr (castPtr)+import Foreign.C.Structs.Utils (next, sizeof, fmax)++-- | All @StructN@ types and their instances of 'Storable' are declared using 'structT'.+-- It can theoretically create C structs with an infinite number of fields.+-- The parameter of 'structT' is the number of fields the struct type should have.+-- Its constructor and type will both be named @StructN@ where N is equal to the argument to 'structT'.+structT :: Int -> DecsQ+structT = return . zipWith ($) [structTypeT, storableInstanceT] . repeat++-- | Access function for fields of a @StructN@ where @N@ is the number of fields in the struct.+-- N is the first argument passed to 'acs', while the second is the field number.+-- The first field has number 1, the second 2 and so on.+--+-- > s = Struct4 1 2 3 4+-- > $(acs 4 3) s+--+acs :: Int -> Int -> ExpQ+acs big_n small_n = [| \struct -> $(caseE [| struct |] [m]) |]+    where m :: MatchQ+          m = match pat (normalB $ varE $ vrs !! (small_n-1)) []+          pat :: PatQ+          pat = conP str $ map varP $ take big_n vrs+          str = mkName $ "Struct" ++ show big_n+          vrs = fieldnames ""++-- Templating functions++structTypeT :: Int -> Dec+#if __GLASGOW_HASKELL__ < 800+structTypeT nfields = DataD [] (sTypeN nfields) tyVars [constructor] deriv''+#elif __GLASGOW_HASKELL__ < 802+structTypeT nfields = DataD [] (sTypeN nfields) tyVars Nothing [constructor] deriv'+#else+structTypeT nfields = DataD [] (sTypeN nfields) tyVars Nothing [constructor] [deriv]+#endif+    where tyVars    = map PlainTV $ take nfields $ fieldnames ""+          constructor = RecC (sTypeN nfields) $ take nfields records+          records     = zipWith defRec (getters nfields) (fieldnames "")+#if __GLASGOW_HASKELL__ < 800+          defRec n t  = (,,) n NotStrict (VarT t)+#else+          defRec n t  = (,,) n (Bang NoSourceUnpackedness NoSourceStrictness) (VarT t)+#endif+          deriv'' = [''Show, ''Eq]+          deriv' = map ConT deriv''+#if __GLASGOW_HASKELL__ > 800+          deriv = DerivClause Nothing deriv'+#endif++storableInstanceT :: Int -> Dec+#if __GLASGOW_HASKELL__ < 800+storableInstanceT nfields = InstanceD cxt tp decs+#else+storableInstanceT nfields = InstanceD Nothing cxt tp decs+#endif+    where vars = take nfields $ fieldnames ""+          storable = AppT $ ConT ''Storable+#if __GLASGOW_HASKELL__ < 710+          cxt  = map (\v -> ClassP ''Storable [VarT v]) vars+#else+          cxt  = map (storable . VarT) vars+#endif+          tp   = storable $ foldl AppT (ConT $ sTypeN nfields) $ map VarT vars++          decs = [ sizeOfT nfields+                 , alignmentT nfields+                 , peekT nfields+                 , pokeT nfields+                 ]++-- Storable instance function temaples++sizeOfT :: Int -> Dec+sizeOfT nfields = FunD 'sizeOf [clause]+    where clause = Clause [VarP struct] (NormalB body) wheres+          body = AppE (AppE (VarE 'sizeof) $ alignments "a") (sizes "s")+          alignments = ListE . take nfields . map VarE . fieldnames+          sizes = ListE . take nfields . map VarE . fieldnames+          wheres = vals 'alignment nfields "a" ++ vals 'sizeOf nfields "s"++alignmentT :: Int -> Dec+alignmentT nfields = FunD 'alignment [clause]+     where clause = Clause [VarP struct] (NormalB body) wheres+           body = AppE (VarE 'fmax) (ListE $ take nfields $ map VarE $ fieldnames "")+           wheres = vals 'alignment nfields ""++peekT :: Int -> Dec+peekT nfields = FunD 'peek [clause]+    where+          vars = take nfields $ fieldnames ""+          ptrs = tail $ take nfields $ fieldnames "_ptr"+          clause = Clause [VarP ptr] (NormalB body) []++          body = DoE $ initial ++ concat gotos ++ final+          initial = [ BindS (VarP $ head vars) (AppE (VarE 'peek) castPtr')+                    , BindS (VarP $ head ptrs) (AppE (AppE (VarE 'next) $ VarE ptr) $ VarE $ head vars)+                  ]+          gotos = zipWith3 goto (tail vars) ptrs (tail ptrs)+          goto n p next_p = [bindVar' p n, bindPtr' next_p p (VarE n)]++          final = [ bindVar' (last ptrs) (last vars)+                  , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE (sTypeN nfields)) (map VarE vars)+                ]++pokeT :: Int -> Dec+pokeT nfields = FunD 'poke [clause]+    where+          vars = take nfields $ fieldnames ""+          ptrs = tail $ take nfields $ fieldnames "_ptr"+          clause = Clause patterns (NormalB body) []++          patterns = [VarP ptr, ConP (sTypeN nfields) (map VarP vars)]+          body = DoE $ [init_poke, init_next] ++ concat gotos ++ [final]++          init_poke = NoBindS+                    $ AppE cast_poke_ptr (VarE $ head vars)+                    where  cast_poke_ptr = AppE (VarE 'poke) castPtr'+          init_next = bindPtr' (head ptrs) ptr (VarE $ head vars)++          gotos = zipWith3 goto (tail vars) ptrs $ tail ptrs+          goto n p next_p = [pokeVar' p var, bindPtr' next_p p var]+                where var = VarE n++          final = pokeVar' (last ptrs) (VarE $ last vars)++-- Helpers and Constants++sTypeN n = mkName ("Struct" ++ show n)+struct   = mkName "struct"+ptr      = mkName "ptr"+castPtr' = AppE (VarE 'castPtr) (VarE ptr)++fieldnames :: String -> [Name]+fieldnames s = map (mkName . (:s)) ['a'..'z']+getters    :: Int -> [Name]+getters n = map (mkName . (("s" ++ show n) ++))+          $  ["1st","2nd","3rd"]+          ++ [show n ++ "th" | n <- [4..]]++vals f n s = take n $ zipWith val (fieldnames s) (getters n)+    where val v getter = ValD (VarP v) (NormalB $ body getter) []+          body getter  = AppE (VarE f) $ AppE (VarE getter) $ VarE struct++bindVar' ptr var = BindS (VarP var) (AppE (VarE 'peek) $ VarE ptr)+pokeVar' ptr var = NoBindS+       $ AppE (AppE (VarE 'poke) $ VarE ptr) var+bindPtr' np pp var = BindS (VarP np)+       $ AppE next_ptr var+       where next_ptr = AppE (VarE 'next) $ VarE pp+
+ src/Foreign/C/Structs/Types.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+{- |+Module          : Foreign.C.Structs.Types+Description     : Create C structs from Haskell+Copyright       : (c) Simon Plakolb, 2020+License         : MIT+Maintainer      : s.plakolb@gmail.com+Stability       : beta++This module creates tuples with up to 6 fields.+-}+module Foreign.C.Structs.Types (+    Struct2(..), Struct3(..), Struct4(..), Struct5(..), Struct6(..)+) where++import Foreign.Storable (Storable, peek, poke, alignment, sizeOf)+import Foreign.Ptr (Ptr, castPtr)++import Foreign.C.Structs.Utils+import Foreign.C.Structs.Templates (structT)++-- | A 'Struct2' can hold two records of any 'Storable' types @a@ and @b@.+-- It is itself an instance of 'Storable' and can be used inside a 'Ptr'.+-- The 'Struct2' constructor takes two arguments.+-- The record functions 's21st' and 's22nd' provide access to the fields values.+structT 2+-- | A 'Struct3' can hold three records of any 'Storable' types @a@, @b@ and @c@.+-- It is itself an instance of 'Storable' and can be used inside a 'Ptr'.+-- The 'Struct3' constructor takes three arguments.+-- The record functions 's31st', 's32nd' and 's33rd' provide access to the fields values.+structT 3+-- | A 'Struct4' can hold four records of any 'Storable' types @a@, @b@, @c@ and @d@.+-- It is itself an instance of 'Storable' and can be used inside a 'Ptr'.+-- The 'Struct4' constructor takes four arguments.+-- The record functions 's41st', 's42nd', 's43rd' and 's44th' provide access to the fields values.+structT 4+-- | A 'Struct5' can hold five records of any 'Storable' types @a@, @b@, @c@, @d@ and @e@.+-- It is itself an instance of 'Storable' and can be used inside a 'Ptr'.+-- The 'Struct5' constructor takes five arguments.+-- The record functions 's51st', 's52nd', 's53rd', 's54th' and 's55th' provide access to the fields values.+structT 5+-- | A 'Struct6' can hold six records of any 'Storable' types @a@, @b@, @c@, @d@, @e@ and @f@.+-- It is itself an instance of 'Storable' and can be used inside a 'Ptr'.+-- The 'Struct6' constructor takes six arguments.+-- The record functions 's61st', 's62nd', 's63rd', 's64th', 's65th' and 's66th' provide access to the fields values.+structT 6+
+ src/Foreign/C/Structs/Utils.hs view
@@ -0,0 +1,45 @@+{- |+Module          : Foreign.C.Structs.Utils+Description     : Create C structs from Haskell+Copyright       : (c) Simon Plakolb, 2020+License         : MIT+Maintainer      : s.plakolb@gmail.com+Stability       : beta++This module defined some utility functions for Storable instance declarations.+-}+module Foreign.C.Structs.Utils (+      next, fmax, sizeof+) where++import Foreign.Storable (Storable, peek, sizeOf, alignment)+import Foreign.Marshal (alloca)+import Foreign.Ptr (Ptr, plusPtr, alignPtr)++-- | Due to alignment constraints the size of C structs is dependent on the order of fields and their respectible sizes. The function 'sizeof' can calculate the resulting size given a list of all 'alignments' and 'sizes'.+sizeof :: [Int] -> [Int] -> Int+sizeof alignments sizes = sizeof' 0 alignments sizes+    where+          sizeof' 0 (a:as) (s:ss) = sizeof' s as ss+          sizeof' s [] [] = s `pad` foldr max 0 alignments+          sizeof' x (a:as) (s:ss) = let+                            s' = x+s+                            in sizeof' (s' `pad` a) as ss++pad x a+  | x `mod` a == 0 = x+  | otherwise      = pad (x+1) a++-- | Jumps to the next pointer location in the struct.+next :: (Storable a, Storable b, Storable c) => Ptr a -> b -> IO (Ptr c)+next ptr x = alloca $ next' ptr x+    where next' :: (Storable a, Storable b, Storable c) => Ptr a -> b -> Ptr c -> IO (Ptr c)+          next' ptr x ptr_x = do+                let ptr_y = plusPtr ptr $ sizeOf x+                y <- peek ptr_x+                return $ alignPtr ptr_y $ alignment y++-- | Alias for @foldr max 0@.+fmax :: Integral a => [a] -> a+fmax = foldr max 0+
+ test/CTest.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ForeignFunctionInterface, TemplateHaskell #-}+module CTest where++import Test.Framework.Providers.API (testGroup)+import Templates++import Foreign.C.Types+import Foreign.C.Structs++i = 63 :: CInt+d = 63.63 :: CDouble+f = 42.42 :: CFloat+ch = 1 :: CChar++s2id = Struct2 i d+s2ii = Struct2 i i+s2df = Struct2 d f++s3icd = Struct3 i ch d+s3idc = Struct3 i d ch++s4icdd = Struct4 i ch d d+s4iddi = Struct4 i d  d i+s4dicc = Struct4 d i ch ch++c "sIntDouble"   's2id+c "sIntInt"      's2ii+c "sDoubleFloat" 's2df++c "sIntCharDouble" 's3icd+c "sIntDoubleChar" 's3idc++c "sIntCharDoubleDouble" 's4icdd+c "sIntDoubleDoubleInt"  's4iddi+c "sDoubleIntCharChar"   's4dicc++tests = testGroup "ForeignImports" [+      case_sIntDouble, case_sIntInt, case_sDoubleFloat+    , case_sIntCharDouble, case_sIntDoubleChar+    , case_sIntCharDoubleDouble, case_sIntDoubleDoubleInt, case_sDoubleIntCharChar+    ]
+ test/DocTest.hs view
@@ -0,0 +1,7 @@+module Main where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main = glob "src/**/*.hs" >>= doctest+
+ test/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Test.Framework.Runners.Console (defaultMain)++import qualified UnitTests (tests)+import qualified Properties (tests)+import qualified CTest (tests)++main = defaultMain $ [Properties.tests, UnitTests.tests, CTest.tests]+
+ test/Properties.hs view
@@ -0,0 +1,106 @@+module Properties where++import Test.QuickCheck (Property, Arbitrary, arbitrary)+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Test.Framework.Providers.API (testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Foreign.C.Types (CChar, CInt, CDouble)+import Foreign.Storable (Storable, peek)+import Foreign.Marshal.Utils (new)+import Foreign.Marshal.Alloc (free)+import Foreign.C.Structs (Struct2(..), Struct3(..), Struct4(..))++tests = testGroup "Properties" [test_idStruct2, test_idStruct3, test_idStruct4]++test_idStruct2 = testGroup "Identity Struct2" [+      testProperty "Double Double"  (prop_idStruct2 :: Struct2 Double Double -> Property)+    , testProperty "Int Int"        (prop_idStruct2 :: Struct2 Int Int       -> Property)+    , testProperty "Int CInt"       (prop_idStruct2 :: Struct2 Int CInt      -> Property)+    , testProperty "CChar CInt"     (prop_idStruct2 :: Struct2 CChar CInt    -> Property)+    ]++test_idStruct3 = testGroup "Identity Struct3" [+      testProperty "Double Int CChar" (prop_idStruct3 :: Struct3 Double Int CChar -> Property)+    , testProperty "CChar Double Int" (prop_idStruct3 :: Struct3 CChar Double Int -> Property)+    , testProperty "Int Double CChar" (prop_idStruct3 :: Struct3 Int Double CChar -> Property)+    , testProperty "CChar CChar CChar" (prop_idStruct3 :: Struct3 CChar CChar CChar -> Property)+    ]++test_idStruct4 = testGroup "Identity Struct4" [+      testProperty "Int Double Int CChar" (prop_idStruct4 :: Struct4 Int Double Int CChar -> Property)+    , testProperty "Int Int Double CChar" (prop_idStruct4 :: Struct4 Int Int Double CChar -> Property)+    , testProperty "Int Double Int Double" (prop_idStruct4 :: Struct4 Int Double Int Double -> Property)+    , testProperty "Double Int Char Char" (prop_idStruct4 :: Struct4 Double Int Char Char -> Property)+    , testProperty "CChar Int CChar Double" (prop_idStruct4 :: Struct4 CChar Int CChar Double -> Property)+    , testProperty "Double Double CChar CInt" (prop_idStruct4 :: Struct4 Double Double CChar CInt -> Property)+    , testProperty "CChar CInt Double CChar" (prop_idStruct4 :: Struct4 CChar CInt Double CChar -> Property)+    , testProperty "CChar Double CInt Double" (prop_idStruct4 :: Struct4 CChar Double CInt Double -> Property)+    , testProperty "CChar CChar CChar CChar" (prop_idStruct4 :: Struct4 CChar CChar CChar CChar -> Property)+    ]++instance ( Storable a, Arbitrary a+         , Storable b, Arbitrary b+         ) => Arbitrary (Struct2 a b) where+    arbitrary = do+            a <- arbitrary+            b <- arbitrary+            return $ Struct2 a b++instance ( Storable a, Arbitrary a+         , Storable b, Arbitrary b+         , Storable c, Arbitrary c+         ) => Arbitrary (Struct3 a b c) where+    arbitrary = do+            a <- arbitrary+            b <- arbitrary+            c <- arbitrary+            return $ Struct3 a b c++instance ( Storable a, Arbitrary a+         , Storable b, Arbitrary b+         , Storable c, Arbitrary c+         , Storable d, Arbitrary d+         ) => Arbitrary (Struct4 a b c d) where+    arbitrary = do+            a <- arbitrary+            b <- arbitrary+            c <- arbitrary+            d <- arbitrary+            return $ Struct4 a b c d++identity2 struct = do+    ptr_struct <- new struct+    struct'    <- peek ptr_struct+    free ptr_struct+    return struct'++prop_idStruct2 :: (Storable a, Storable b, Eq a, Eq b) => Struct2 a b -> Property+prop_idStruct2 struct = monadicIO $ do+    struct' <- run (identity2 struct)+    assert (struct' == struct)++identity3 struct = do+    ptr_struct <- new struct+    struct'    <- peek ptr_struct+    free ptr_struct+    return struct'++prop_idStruct3 :: (Storable a, Storable b, Storable c, Eq a, Eq b, Eq c) => Struct3 a b c -> Property+prop_idStruct3 struct = monadicIO $ do+    struct' <- run (identity3 struct)+    assert (struct' == struct)++identity4 struct = do+    ptr_struct <- new struct+    struct'    <- peek ptr_struct+    free ptr_struct+    return struct'++prop_idStruct4 :: ( Storable a, Storable b, Storable c, Storable d+                  , Eq a, Eq b, Eq c, Eq d+                  ) => Struct4 a b c d -> Property+prop_idStruct4 struct = monadicIO $ do+    struct' <- run (identity4 struct)+    assert (struct' == struct)+
+ test/Templates.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module Templates where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift)+import Foreign.Ptr (Ptr)+import Foreign.Marshal.Alloc (free)+import Foreign.Storable (peek)+import Test.HUnit ((@?=))+import Test.Framework.Providers.HUnit (testCase)++peek' ptr = do+      val <- peek ptr+      free ptr+      return val++c :: String -> Name -> DecsQ+c cname res = do+#if __GLASGOW_HASKELL__ < 800+    VarI n t _ _ <- reify res+#else+    VarI n t _ <- reify res+#endif+    typ <- ptr $ return t+    let name = mkName cname+        deq  = ForeignD $ ImportF CCall Safe cname name typ+        body = normalB [| testCase cname $ (peek' $(varE name)) >>= (@?= $(varE n)) |]+        test = funD (mkName $ "case_" ++ cname) [clause [] body []]+    sequence [return deq, test]++ptr t = [t| Ptr $(t) |]++size :: Name -> Int -> DecsQ+size uname res = let+                  sname = show uname+                  body = normalB [| testCase sname $ sizeOf $(varE uname) @?= res |]+                  clauses = [clause [] body []]+    in sequence [funD (mkName $ "case_" ++ sname) clauses]++to_struct_type :: [TypeQ] -> TypeQ+to_struct_type ts = [t| Ptr $(mk_struct) |]+    where struct = conT (mkName $ "Struct" ++ (show $ length ts))+          mk_struct :: TypeQ+          mk_struct = foldr appT struct ts+
+ test/UnitTests.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}+module UnitTests (+    tests+) where++import Test.Framework.Providers.API (testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))++import Foreign.C.Structs (Struct2(Struct2), Struct3(Struct3), Struct4(Struct4), structT)+import Foreign.Storable (sizeOf)+import Foreign.C.Types (CInt, CChar, CFloat, CDouble)++i = i :: CInt+d = d :: CDouble+f = 0.2 :: CFloat+c = 8 :: CChar++sizeOfStruct2 = testGroup "sizeOfStruct2" [+      testCase "DoubleChar" $ 16 @=? (sizeOf $ Struct2 d c)+    , testCase "CharDouble" $ 16 @=? (sizeOf $ Struct2 c d)+    , testCase "IntInt"     $  8 @=? (sizeOf $ Struct2 i i)+    ]++sizeOfStruct3 = testGroup "sizeOfStruct3" [+      testCase "intDoubleChar" $ 24 @=? (sizeOf $ Struct3 i d c)+    , testCase "intCharDouble" $ 16 @=? (sizeOf $ Struct3 i c d)+    , testCase "doubleIntChar" $ 16 @=? (sizeOf $ Struct3 d i c)+    , testCase "doubleCharInt" $ 16 @=? (sizeOf $ Struct3 d c i)+    , testCase "charIntDouble" $ 16 @=? (sizeOf $ Struct3 c i d)+    , testCase "charDoubleInt" $ 24 @=? (sizeOf $ Struct3 c d i)+    , testCase "doubleDoubleDouble" $ 24 @=? (sizeOf $ Struct3 d d d)+    , testCase "intIntInt" $ 12 @=? (sizeOf $ Struct3 i i i)+    , testCase "charCharChar" $ 3 @=? (sizeOf $ Struct3 c c c)+    ]++sizeOfStruct4 = testGroup "sizeOfStruct4" [+      testCase "intIntDoubleChar" $ 24 @=? (sizeOf $ Struct4 i i d c)+    , testCase "charIntCharDouble" $ 24 @=? (sizeOf $ Struct4 c i c d)+    , testCase "intDoubleIntChar" $ 24 @=? (sizeOf $ Struct4 i d i c)+    , testCase "doubleDoubleCharInt" $ 24 @=? (sizeOf $ Struct4 d d c i)+    , testCase "charIntDoubleChar" $ 24 @=? (sizeOf $ Struct4 c i d c)+    , testCase "charDoubleIntDouble" $ 32 @=? (sizeOf $ Struct4 c d i d)+    , testCase "doubleDoubleDoubleDouble" $ 32 @=? (sizeOf $ Struct4 d d d d)+    , testCase "intIntIntInt" $ 16 @=? (sizeOf $ Struct4 i i i i)+    , testCase "charCharCharChar" $ 4 @=? (sizeOf $ Struct4 c c c c)+    ]++structT 8++sizeOfStruct8 = testGroup "sizeOfStruct8" [+      testCase "s8ccccdcci" $ 24 @=? (sizeOf $ Struct8 c c c c d c c i)+    , testCase "s8ccccdcic" $ 32 @=? (sizeOf $ Struct8 c c c c d c i c)+    ]++tests = testGroup "UnitTests" [+      sizeOfStruct2+    , sizeOfStruct3+    , sizeOfStruct4+    , sizeOfStruct8+    ]+
+ test/libs/c_test.c view
@@ -0,0 +1,75 @@+#include <stdlib.h>+#include "c_test.h"++struct StructIntDouble *sIntDouble(void) {+    struct StructIntDouble *s;+    s = malloc(sizeof(struct StructIntDouble));+    s->s2fst = 63;+    s->s2snd = 63.63;+    return s;+}++struct StructIntInt *sIntInt(void) {+    struct StructIntInt *s;+    s = malloc(sizeof(struct StructIntInt));+    s->s2fst = 63;+    s->s2snd = 63;+    return s;+}++struct StructDoubleFloat *sDoubleFloat(void) {+    struct StructDoubleFloat *s;+    s = malloc(sizeof(struct StructDoubleFloat));+    s->s2fst = 63.63;+    s->s2snd = 42.42;+    return s;+}++struct StructIntCharDouble *sIntCharDouble(void) {+    struct StructIntCharDouble *s;+    s = malloc(sizeof(struct StructIntCharDouble));+    s->s3fst = 63;+    s->s3snd = 1;+    s->s3trd = 63.63;+    return s;+}++struct StructIntDoubleChar *sIntDoubleChar(void) {+    struct StructIntDoubleChar *s;+    s = malloc(sizeof(struct StructIntDoubleChar));+    s->s3fst = 63;+    s->s3snd = 63.63;+    s->s3trd = 1;+    return s;+}++struct StructIntCharDoubleDouble *sIntCharDoubleDouble(void) {+    struct StructIntCharDoubleDouble *s;+    s = malloc(sizeof(struct StructIntCharDoubleDouble));+    s->s4fst = 63;+    s->s4snd = 1;+    s->s4trd = 63.63;+    s->s4fth = 63.63;+    return s;+}++struct StructIntDoubleDoubleInt *sIntDoubleDoubleInt(void) {+    struct StructIntDoubleDoubleInt *s;+    s = malloc(sizeof(struct StructIntDoubleDoubleInt));+    s->s4fst = 63;+    s->s4snd = 63.63;+    s->s4trd = 63.63;+    s->s4fth = 63;+    return s;+}++struct StructDoubleIntCharChar *sDoubleIntCharChar(void) {+    struct StructDoubleIntCharChar *s;+    s = malloc(sizeof(struct StructDoubleIntCharChar));+    s->s4fst = 63.63;+    s->s4snd = 63;+    s->s4trd = 1;+    s->s4fth = 1;+    return s;+}+
+ test/libs/c_test.h view
@@ -0,0 +1,61 @@+#ifndef C_TEST+#define C_TEST++struct StructIntDouble {+    int s2fst;+    double s2snd;+};++struct StructIntInt {+    int s2fst;+    int s2snd;+};++struct StructDoubleFloat {+    double s2fst;+    float  s2snd;+};++struct StructIntCharDouble {+    int s3fst;+    char s3snd;+    double s3trd;+};++struct StructIntDoubleChar {+    int s3fst;+    double s3snd;+    char s3trd;+};++struct StructIntCharDoubleDouble {+    int s4fst;+    char s4snd;+    double s4trd;+    double s4fth;+};++struct StructIntDoubleDoubleInt {+    int s4fst;+    double s4snd;+    double s4trd;+    int s4fth;+};++struct StructDoubleIntCharChar {+    double s4fst;+    int s4snd;+    char s4trd;+    char s4fth;+};++struct StructIntDouble *sIntDouble(void);+struct StructIntInt *sIntInt(void);+struct StructDoubleFloat *sDoubleFloat(void);+struct StructIntCharDouble *sIntCharDouble(void);+struct StructIntDoubleChar *sIntDoubleChar(void);+struct StructIntCharDoubleDouble *sIntCharDoubleDouble(void);+struct StructIntDoubleDoubleInt *sIntDoubleDoubleInt(void);+struct StructDoubleIntCharChar *sDoubleIntCharChar(void);++#endif // C_TEST