diff options
author | SimonPlakolb <> | 2021-01-13 08:56:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2021-01-13 08:56:00 (GMT) |
commit | b6e5b8587b4c0a6ea9a82c806f57262bc9bb3b67 (patch) | |
tree | 5d0e1b8f0a12d6855f3862cd2402a4f441361407 | |
parent | 12507b372bcce06d910753d2cf72b403f1382cd1 (diff) |
-rw-r--r-- | C-structs.cabal | 8 | ||||
-rwxr-xr-x | CHANGELOG.md | 4 | ||||
-rwxr-xr-x | README.md | 13 | ||||
-rw-r--r-- | src/Foreign/C/Structs.hs | 74 | ||||
-rw-r--r-- | src/Foreign/C/Structs/Templates.hs | 69 | ||||
-rw-r--r-- | src/Foreign/C/Structs/Types.hs | 2 | ||||
-rw-r--r-- | src/Foreign/C/Structs/Utils.hs | 18 | ||||
-rw-r--r-- | test/Templates.hs | 2 |
8 files changed, 118 insertions, 72 deletions
diff --git a/C-structs.cabal b/C-structs.cabal index 0123156..67a5018 100644 --- a/C-structs.cabal +++ b/C-structs.cabal @@ -1,11 +1,11 @@ Name: C-structs -Version: 0.1.0.1 +Version: 0.2.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 +Homepage: https://github.com/pinselimo/cstructs-in-haskell#readme Synopsis: C-Structs implementation for Haskell Description: C-structs lets you create correct C structs in Haskell. @@ -61,11 +61,11 @@ Test-Suite unit-tests C-structs, base >= 3.0 && < 5.0, HUnit >= 1.2 && < 1.7, - QuickCheck >= 2.3 && < 2.15, + QuickCheck >= 2.10 && < 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-framework-quickcheck2 >= 0.3.0.4 && < 0.4 Test-Suite doctest type: exitcode-stdio-1.0 diff --git a/CHANGELOG.md b/CHANGELOG.md index ae744cf..67c4611 100755 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,2 +1,6 @@ +v0.2.0.1: Remove re-exports of Foreign.C.Storable and Foreign.C.Ptr members + +v0.1.0.2: Better Haddock and a fixed C-test template for GHC < 8.0 + v0.1.0.1: Added thorough testing and structs with up to four fields @@ -7,7 +7,6 @@ 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. @@ -107,6 +106,16 @@ data Struct8 = Struct8 instance Storable Struct8 ... ~~~ +### Accessors + +The naming scheme of the accessor functions follows the names of the ordinal numbers. This can be inconvenient in a Template Haskell context. For these situations ```Foreign.C.Structs``` exposes the ```acs``` function: + +~~~haskell +$(acs 8 2) +~~~ + +This expression will be spliced into a function taking a ```Struct8``` and extracting its second field. + ## Testing Identity properties are tested with QuickCheck to ensure that peek and poke are reversible. @@ -114,7 +123,7 @@ The result of ```sizeOf``` is dependent on the order of types. Its correctness c 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. +All tests are performed for all available GHC/CABAL/Stack versions through the [Stack CI script](https://docs.haskellstack.org/en/stable/travis_ci/) on both Linux and OSX to ensure maximum compatibility. ## License diff --git a/src/Foreign/C/Structs.hs b/src/Foreign/C/Structs.hs index d1c4044..279df4f 100644 --- a/src/Foreign/C/Structs.hs +++ b/src/Foreign/C/Structs.hs @@ -7,6 +7,30 @@ Maintainer : s.plakolb@gmail.com Stability : beta 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 + +> 2nd :: Struct2 a b -> b + + * Pattern matching + +> (Struct2 a b) + + * Template Haskell 'acs' function. + +> $(acs 2 2) :: Struct2 a b -> b + -} module Foreign.C.Structs ( Struct2(..) @@ -18,52 +42,24 @@ module Foreign.C.Structs ( , 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(..) + Struct2(..) + , Struct3(..) + , Struct4(..) + , Struct5(..) + , Struct6(..) ) import Foreign.C.Structs.Templates ( - structT - ,acs + structT + , acs ) -import Foreign.Storable ( - Storable, peek, poke, sizeOf, alignment - ) -import Foreign.Ptr ( - castPtr - ) import Foreign.C.Structs.Utils ( - next - ,sizeof - ,fmax + 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. --} - diff --git a/src/Foreign/C/Structs/Templates.hs b/src/Foreign/C/Structs/Templates.hs index 1814ae0..26d915d 100644 --- a/src/Foreign/C/Structs/Templates.hs +++ b/src/Foreign/C/Structs/Templates.hs @@ -35,25 +35,32 @@ structT = return . zipWith ($) [structTypeT, storableInstanceT] . repeat -- acs :: Int -> Int -> ExpQ acs big_n small_n = [| \struct -> $(caseE [| struct |] [m]) |] - where m :: MatchQ + 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'' +structTypeT nfields = DataD [] (structType nfields) tyVars [constructor] deriv'' #elif __GLASGOW_HASKELL__ < 802 -structTypeT nfields = DataD [] (sTypeN nfields) tyVars Nothing [constructor] deriv' +structTypeT nfields = DataD [] (structType nfields) tyVars Nothing [constructor] deriv' #else -structTypeT nfields = DataD [] (sTypeN nfields) tyVars Nothing [constructor] [deriv] +structTypeT nfields = DataD [] (structType nfields) tyVars Nothing [constructor] [deriv] #endif - where tyVars = map PlainTV $ take nfields $ fieldnames "" - constructor = RecC (sTypeN nfields) $ take nfields records + where + tyVars = map PlainTV $ take nfields $ fieldnames "" + + constructor = RecC (structType nfields) $ take nfields records + records = zipWith defRec (getters nfields) (fieldnames "") #if __GLASGOW_HASKELL__ < 800 defRec n t = (,,) n NotStrict (VarT t) @@ -61,6 +68,7 @@ structTypeT nfields = DataD [] (sTypeN nfields) tyVars Nothing [constructor] [de 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' @@ -72,14 +80,16 @@ storableInstanceT nfields = InstanceD cxt tp decs #else storableInstanceT nfields = InstanceD Nothing cxt tp decs #endif - where vars = take nfields $ fieldnames "" + 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 + tp = storable $ foldl AppT (ConT $ structType nfields) $ map VarT vars decs = [ sizeOfT nfields , alignmentT nfields @@ -91,52 +101,71 @@ storableInstanceT nfields = InstanceD Nothing cxt tp decs sizeOfT :: Int -> Dec sizeOfT nfields = FunD 'sizeOf [clause] - where clause = Clause [VarP struct] (NormalB body) wheres + 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 + 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) - ] + , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE (structType 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)] + patterns = [VarP ptr, ConP (structType 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 @@ -144,25 +173,33 @@ pokeT nfields = FunD 'poke [clause] -- Helpers and Constants -sTypeN n = mkName ("Struct" ++ show n) +structType 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) [] + 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 diff --git a/src/Foreign/C/Structs/Types.hs b/src/Foreign/C/Structs/Types.hs index ea7d664..f81bf41 100644 --- a/src/Foreign/C/Structs/Types.hs +++ b/src/Foreign/C/Structs/Types.hs @@ -16,7 +16,7 @@ module Foreign.C.Structs.Types ( import Foreign.Storable (Storable, peek, poke, alignment, sizeOf) import Foreign.Ptr (Ptr, castPtr) -import Foreign.C.Structs.Utils +import Foreign.C.Structs.Utils (next, fmax, sizeof) import Foreign.C.Structs.Templates (structT) -- | A 'Struct2' can hold two records of any 'Storable' types @a@ and @b@. diff --git a/src/Foreign/C/Structs/Utils.hs b/src/Foreign/C/Structs/Utils.hs index e5e19a0..7f28de2 100644 --- a/src/Foreign/C/Structs/Utils.hs +++ b/src/Foreign/C/Structs/Utils.hs @@ -18,22 +18,22 @@ 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 +sizeof as@(_:alignments) (s:sizes) = sizeof' s alignments sizes where - sizeof' 0 (a:as) (s:ss) = sizeof' s as ss - sizeof' s [] [] = s `pad` foldr max 0 alignments + sizeof' s [] [] = s `pad` fmax as sizeof' x (a:as) (s:ss) = let - s' = x+s - in sizeof' (s' `pad` a) as ss + s' = x+s + in sizeof' (s' `pad` a) as ss -pad x a - | x `mod` a == 0 = x - | otherwise = pad (x+1) a + 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) + 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 diff --git a/test/Templates.hs b/test/Templates.hs index c180422..635161e 100644 --- a/test/Templates.hs +++ b/test/Templates.hs @@ -5,7 +5,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift) import Foreign.Ptr (Ptr) import Foreign.Marshal.Alloc (free) -import Foreign.Storable (peek) +import Foreign.Storable (peek, sizeOf) import Test.HUnit ((@?=)) import Test.Framework.Providers.HUnit (testCase) |