{-# LANGUAGE ScopedTypeVariables #-}

module Hedgehog.Classes.Storable (storableLaws) where

import Hedgehog
import Hedgehog.Classes.Common
import Hedgehog.Internal.Gen (sample)

import qualified Data.List as List
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import GHC.Ptr (Ptr(..), nullPtr, plusPtr, minusPtr, alignPtr)
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)

-- | Tests the following 'Storable' laws:
--
-- [__Set-Get__]: @'pokeElemOff' ptr ix a '>>' 'peekElemOff' ptr ix@ ≡ @'pure' a@
-- [__Get-Set__]: @'peekElemOff' ptr ix '>>=' 'pokeElemOff' ptr ix@ ≡ @'pure' ()@ (Putting back what you got out has no effect)
-- [__List Conversion Roundtrips__]: Mallocing a list and then reconstructing it gives you the same list
-- [__PeekElemOff/Peek__]: @'peekElemOff' a i@ ≡ @'peek' ('plusPtr' a (i '*' 'sizeOf' 'undefined'))@
-- [__PokeElemOff/Poke__]: @'pokeElemOff' a i x@ ≡ @'poke' ('plusPtr' a (i '*' 'sizeOf' 'undefined')) x@
-- [__PeekByteOff/Peek__]: @'peekByteOff' a i@ ≡ @'peek' ('plusPtr' a i)@
-- [__PokeByteOff/Peek__]: @'pokeByteOff' a i x@ ≡ @'poke' ('plusPtr' a i) x@
storableLaws :: (Eq a, Show a, Storable a) => Gen a -> Laws
storableLaws :: Gen a -> Laws
storableLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Storable"
  [ (String
"Set-Get (you get back what you put in)", Gen a -> Property
forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableSetGet Gen a
gen)
  , (String
"Get-Set (putting back what you got out has no effect)", Gen a -> Property
forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableGetSet Gen a
gen)
  , (String
"List Conversion Roundtrips", Gen a -> Property
forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableList Gen a
gen)
  , (String
"peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", Gen a -> Property
forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePeekElem Gen a
gen)
  , (String
"pokeElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", Gen a -> Property
forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePokeElem Gen a
gen)
  , (String
"peekByteOff a i ≡ peek (plusPtr a i)", Gen a -> Property
forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePeekByte Gen a
gen)
  , (String
"pokeByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", Gen a -> Property
forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePokeByte Gen a
gen)
  ]

genArray :: forall a. (Storable a) => Gen a -> Int -> IO (Ptr a)
genArray :: Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len = do
  let go :: Int -> [a] -> f [a]
go Int
ix [a]
xs = if Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len
        then [a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs
        else do
          a
x <- Gen a -> f a
forall (m :: * -> *) a. MonadIO m => Gen a -> m a
sample Gen a
gen
          Int -> [a] -> f [a]
go (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
  [a]
as <- Int -> [a] -> IO [a]
forall (f :: * -> *). MonadIO f => Int -> [a] -> f [a]
go Int
0 []
  [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as

storablePeekElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePeekElem :: Gen a -> Property
storablePeekElem Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- Gen [a] -> PropertyT IO [a]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [a] -> PropertyT IO [a]) -> Gen [a] -> PropertyT IO [a]
forall a b. (a -> b) -> a -> b
$ Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- Gen Int -> PropertyT IO Int
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Int -> PropertyT IO Int) -> Gen Int -> PropertyT IO Int
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  IO (PropertyT IO ()) -> PropertyT IO ()
forall a. IO a -> a
unsafePerformIO (IO (PropertyT IO ()) -> PropertyT IO ())
-> IO (PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- Gen a -> Int -> IO (Ptr a)
forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    a
x <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
addr Int
ix
    a
y <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr a
addr Ptr a -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)))
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
addr
    PropertyT IO () -> IO (PropertyT IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> a -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
y)

storablePokeElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePokeElem :: Gen a -> Property
storablePokeElem Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- Gen [a] -> PropertyT IO [a]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [a] -> PropertyT IO [a]) -> Gen [a] -> PropertyT IO [a]
forall a b. (a -> b) -> a -> b
$ Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  a
x <- Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- Gen Int -> PropertyT IO Int
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Int -> PropertyT IO Int) -> Gen Int -> PropertyT IO Int
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  IO (PropertyT IO ()) -> PropertyT IO ()
forall a. IO a -> a
unsafePerformIO (IO (PropertyT IO ()) -> PropertyT IO ())
-> IO (PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- Gen a -> Int -> IO (Ptr a)
forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
addr Int
ix a
x
    a
u <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
addr Int
ix
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr a
addr Ptr a -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf a
x)) a
x
    a
v <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
addr Int
ix
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
addr
    PropertyT IO () -> IO (PropertyT IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
u a -> a -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
v)

storablePeekByte :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePeekByte :: Gen a -> Property
storablePeekByte Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- Gen [a] -> PropertyT IO [a]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [a] -> PropertyT IO [a]) -> Gen [a] -> PropertyT IO [a]
forall a b. (a -> b) -> a -> b
$ Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- Gen Int -> PropertyT IO Int
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Int -> PropertyT IO Int) -> Gen Int -> PropertyT IO Int
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  let off :: Int
off = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Ptr Any
forall a. Ptr a
nullPtr Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` a -> Int
forall a. Storable a => a -> Int
sizeOf ([a] -> a
forall a. [a] -> a
head [a]
as)) Ptr Any -> Int -> Ptr Any
forall a. Ptr a -> Int -> Ptr a
`alignPtr` a -> Int
forall a. Storable a => a -> Int
alignment ([a] -> a
forall a. [a] -> a
head [a]
as) Ptr Any -> Ptr Any -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Any
forall a. Ptr a
nullPtr
  IO (PropertyT IO ()) -> PropertyT IO ()
forall a. IO a -> a
unsafePerformIO (IO (PropertyT IO ()) -> PropertyT IO ())
-> IO (PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- Gen a -> Int -> IO (Ptr a)
forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    a
x :: a <- Ptr a -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
addr Int
off
    a
y :: a <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr a
addr Ptr a -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
addr
    PropertyT IO () -> IO (PropertyT IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> a -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
y)

storablePokeByte :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePokeByte :: Gen a -> Property
storablePokeByte Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- Gen [a] -> PropertyT IO [a]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [a] -> PropertyT IO [a]) -> Gen [a] -> PropertyT IO [a]
forall a b. (a -> b) -> a -> b
$ Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  a
x <- Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
off <- Gen Int -> PropertyT IO Int
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Int -> PropertyT IO Int) -> Gen Int -> PropertyT IO Int
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  IO (PropertyT IO ()) -> PropertyT IO ()
forall a. IO a -> a
unsafePerformIO (IO (PropertyT IO ()) -> PropertyT IO ())
-> IO (PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- Gen a -> Int -> IO (Ptr a)
forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    Ptr a -> Int -> a -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
addr Int
off a
x
    a
u :: a <- Ptr a -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
addr Int
off
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr a
addr Ptr a -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off) a
x
    a
v :: a <- Ptr a -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
addr Int
off
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
addr
    PropertyT IO () -> IO (PropertyT IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
u a -> a -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
v)

storableSetGet :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableSetGet :: Gen a -> Property
storableSetGet Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  a
a <- Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  Int
len <- Gen Int -> PropertyT IO Int
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Int -> PropertyT IO Int) -> Gen Int -> PropertyT IO Int
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
20)
  Int
ix <- Gen Int -> PropertyT IO Int
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Int -> PropertyT IO Int) -> Gen Int -> PropertyT IO Int
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  IO (PropertyT IO ()) -> PropertyT IO ()
forall a. IO a -> a
unsafePerformIO (IO (PropertyT IO ()) -> PropertyT IO ())
-> IO (PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr a
ptr <- Gen a -> Int -> IO (Ptr a)
forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptr Int
ix a
a
    a
a' <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptr Int
ix
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptr
    PropertyT IO () -> IO (PropertyT IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a a -> a -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
a')

storableGetSet :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableGetSet :: Gen a -> Property
storableGetSet Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- Gen [a] -> PropertyT IO [a]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [a] -> PropertyT IO [a]) -> Gen [a] -> PropertyT IO [a]
forall a b. (a -> b) -> a -> b
$ Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- Gen Int -> PropertyT IO Int
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Int -> PropertyT IO Int) -> Gen Int -> PropertyT IO Int
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  IO (PropertyT IO ()) -> PropertyT IO ()
forall a. IO a -> a
unsafePerformIO (IO (PropertyT IO ()) -> PropertyT IO ())
-> IO (PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr a
ptrA <- [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as
    Ptr a
ptrB <- Gen a -> Int -> IO (Ptr a)
forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    Ptr a -> Ptr a -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray Ptr a
ptrB Ptr a
ptrA Int
len
    a
a <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptrA Int
ix
    Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptrA Int
ix a
a
    Bool
res <- Ptr a -> Ptr a -> Int -> IO Bool
forall a. (Eq a, Storable a) => Ptr a -> Ptr a -> Int -> IO Bool
arrayEq Ptr a
ptrA Ptr a
ptrB Int
len
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptrA
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptrB
    PropertyT IO () -> IO (PropertyT IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
res Bool -> Bool -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== Bool
True)

storableList :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableList :: Gen a -> Property
storableList Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- Gen [a] -> PropertyT IO [a]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [a] -> PropertyT IO [a]) -> Gen [a] -> PropertyT IO [a]
forall a b. (a -> b) -> a -> b
$ Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen 
  IO (PropertyT IO ()) -> PropertyT IO ()
forall a. IO a -> a
unsafePerformIO (IO (PropertyT IO ()) -> PropertyT IO ())
-> IO (PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
    let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
    Ptr a
ptr <- [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as
    let rebuild :: Int -> IO [a]
        rebuild :: Int -> IO [a]
rebuild Int
ix = if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
          then (:) (a -> [a] -> [a]) -> IO a -> IO ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptr Int
ix IO ([a] -> [a]) -> IO [a] -> IO [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO [a]
rebuild (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          else [a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    [a]
asNew <- Int -> IO [a]
rebuild Int
0
    Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptr
    PropertyT IO () -> IO (PropertyT IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as [a] -> [a] -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [a]
asNew)

arrayEq :: forall a. (Eq a, Storable a) => Ptr a -> Ptr a -> Int -> IO Bool
arrayEq :: Ptr a -> Ptr a -> Int -> IO Bool
arrayEq Ptr a
ptrA Ptr a
ptrB Int
len = Int -> IO Bool
go Int
0 where
  go :: Int -> IO Bool
go Int
i = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
    then do
      a
a <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptrA Int
i
      a
b <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptrB Int
i
      if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b
        then Int -> IO Bool
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True