1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
module Spec.Storable (testStorable) where
import Foreign.C.String (CString, newCString, peekCString)
import Foreign.C.Types (CInt)
import Foreign.Ptr (nullPtr, castPtr, plusPtr, minusPtr, alignPtr)
import Foreign.Storable (Storable, sizeOf, alignment, peek, peekByteOff, poke, pokeByteOff)
import Hedgehog (Gen)
import Hedgehog.Classes
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
testStorable :: [(String, [Laws])]
testStorable =
[ ("Int", lawsInt)
, ("Int8", lawsInt8)
, ("Int16", lawsInt16)
, ("Int32", lawsInt32)
, ("Int64", lawsInt64)
, ("Word", lawsWord)
, ("Word8", lawsWord8)
, ("Word16", lawsWord16)
, ("Word32", lawsWord32)
, ("Word64", lawsWord64)
, ("complex struct", lawsStruct)
]
ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b
ranged f = f (Range.constantBounded)
lawsInt, lawsInt8, lawsInt16, lawsInt32, lawsInt64 :: [Laws]
lawsInt = [storableLaws (ranged Gen.int)]
lawsInt8 = [storableLaws (ranged Gen.int8)]
lawsInt16 = [storableLaws (ranged Gen.int16)]
lawsInt32 = [storableLaws (ranged Gen.int32)]
lawsInt64 = [storableLaws (ranged Gen.int64)]
lawsWord, lawsWord8, lawsWord16, lawsWord32, lawsWord64 :: [Laws]
lawsWord = [storableLaws (ranged Gen.word)]
lawsWord8 = [storableLaws (ranged Gen.word8)]
lawsWord16 = [storableLaws (ranged Gen.word16)]
lawsWord32 = [storableLaws (ranged Gen.word32)]
lawsWord64 = [storableLaws (ranged Gen.word64)]
lawsStruct :: [Laws]
lawsStruct = [storableLaws genStruct]
genStruct :: Gen TestStruct
genStruct = TestStruct
<$> fmap fromIntegral (Gen.integral Range.linearBounded :: Gen CInt)
<*> Gen.string (Range.linear 0 16) (Gen.filter (/= '\NUL') Gen.latin1)
data TestStruct = TestStruct
{ testPadding :: Int
, testString :: String
}
deriving (Eq, Show)
instance Storable TestStruct where
sizeOf _ = offsetTest + (sizeOf (undefined :: Int) `max` sizeOf (undefined :: CString))
alignment _ = alignment (undefined :: Int) `lcm` alignment (undefined :: CString)
peek ptr = do
pad <- peek $ castPtr ptr
strPtr <- peekByteOff ptr offsetTest
str <- if strPtr == nullPtr
then return ""
else peekCString strPtr
return $ TestStruct
{ testPadding = pad
, testString = str
}
poke ptr x = do
poke (castPtr ptr) $ testPadding x
strPtr <- newCString $ testString x
pokeByteOff ptr offsetTest strPtr
offsetTest :: Int
offsetTest = (nullPtr `plusPtr` sizeOf int) `alignPtr` alignment string `minusPtr` nullPtr
where int = undefined :: Int
string = undefined :: CString
|
