summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimonPlakolb <>2021-01-13 08:56:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2021-01-13 08:56:00 (GMT)
commitb6e5b8587b4c0a6ea9a82c806f57262bc9bb3b67 (patch)
tree5d0e1b8f0a12d6855f3862cd2402a4f441361407
parent12507b372bcce06d910753d2cf72b403f1382cd1 (diff)
version 0.2.0.1HEAD0.2.0.1master
-rw-r--r--C-structs.cabal8
-rwxr-xr-xCHANGELOG.md4
-rwxr-xr-xREADME.md13
-rw-r--r--src/Foreign/C/Structs.hs74
-rw-r--r--src/Foreign/C/Structs/Templates.hs69
-rw-r--r--src/Foreign/C/Structs/Types.hs2
-rw-r--r--src/Foreign/C/Structs/Utils.hs18
-rw-r--r--test/Templates.hs2
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
diff --git a/README.md b/README.md
index 9822a3a..25c0630 100755
--- a/README.md
+++ b/README.md
@@ -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)