{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wall #-}

module Test.QuickCheck.Classes.Storable
  ( storableLaws
  ) where

import Control.Applicative
import Control.Monad
import Data.Proxy (Proxy)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Storable
import GHC.Ptr (Ptr(..), plusPtr)
import Test.QuickCheck hiding ((.&.))

import Test.QuickCheck.Classes.Internal (Laws(..))

-- | Tests the following 'Storable' properties:
--
-- [/Set-Get/]
--   @('pokeElemOff' ptr ix a >> 'peekElemOff' ptr ix') ≡ 'pure' a@
-- [/Get-Set/]
--   @('peekElemOff' ptr ix >> 'pokeElemOff' ptr ix a) ≡ 'pure' a@
storableLaws :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
storableLaws :: Proxy a -> Laws
storableLaws Proxy a
p = String -> [(String, Property)] -> Laws
Laws String
"Storable"
  [ (String
"Set-Get (you get back what you put in)", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storableSetGet Proxy a
p)
  , (String
"Get-Set (putting back what you got out has no effect)", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storableGetSet Proxy a
p)
  , (String
"Set-Set (if you set something twice, the first set is inconsequential", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storableSetSet Proxy a
p)
  , (String
"List Conversion Roundtrips", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storableList Proxy a
p)
  , (String
"peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storablePeekElem Proxy a
p)
  , (String
"peekElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storablePokeElem Proxy a
p)
  , (String
"peekByteOff a i ≡ peek (plusPtr a i)", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storablePeekByte Proxy a
p)
  , (String
"peekByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", Proxy a -> Property
forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
Proxy a -> Property
storablePokeByte Proxy a
p)
  ]

arrayArbitrary :: forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary :: Int -> IO (Ptr a)
arrayArbitrary = [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray ([a] -> IO (Ptr a)) -> (Int -> IO [a]) -> Int -> IO (Ptr a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Gen [a] -> IO [a]
forall a. Gen a -> IO a
generate (Gen [a] -> IO [a]) -> (Int -> Gen [a]) -> Int -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Gen [a]
forall a. Arbitrary a => Int -> Gen [a]
vector

storablePeekElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storablePeekElem :: Proxy a -> Property
storablePeekElem Proxy a
_ = (Positive Int -> Int -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((Positive Int -> Int -> Property) -> Property)
-> (Positive Int -> Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Positive Int
len) Int
ix' -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let ix :: Int
ix = Int
ix' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
  Ptr a
addr :: Ptr a <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary 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. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int
ix)
  Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
addr
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
==== a
y)

storablePokeElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storablePokeElem :: Proxy a -> Property
storablePokeElem Proxy a
_ = (Positive Int -> a -> Int -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((Positive Int -> a -> Int -> Property) -> Property)
-> (Positive Int -> a -> Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Positive Int
len) (a
x :: a) Int
ix' -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let ix :: Int
ix = Int
ix' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
  Ptr a
addr <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary 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. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int
ix) 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
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (a
u a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
==== a
v)

storablePeekByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storablePeekByte :: Proxy a -> Property
storablePeekByte Proxy a
_ = (Positive Int -> Int -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((Positive Int -> Int -> Property) -> Property)
-> (Positive Int -> Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Positive Int
len) Int
off' -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let off :: Int
off = (Int
off' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len) 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
addr :: Ptr a <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary 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
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
==== a
y)

storablePokeByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storablePokeByte :: Proxy a -> Property
storablePokeByte Proxy a
_ = (Positive Int -> a -> Int -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((Positive Int -> a -> Int -> Property) -> Property)
-> (Positive Int -> a -> Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Positive Int
len) (a
x :: a) Int
off' -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let off :: Int
off = (Int
off' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len) 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
addr :: Ptr a <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary 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
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (a
u a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
==== a
v)

storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableSetGet :: Proxy a -> Property
storableSetGet Proxy a
_ = (a -> Positive Int -> Int -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> Positive Int -> Int -> Property) -> Property)
-> (a -> Positive Int -> Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
a :: a) (Positive Int
len) Int
ix' -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let ix :: Int
ix = Int
ix' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
  Ptr a
ptr <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary 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
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
==== a
a')

storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableGetSet :: Proxy a -> Property
storableGetSet Proxy a
_ = (NonEmptyList a -> Int -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((NonEmptyList a -> Int -> Property) -> Property)
-> (NonEmptyList a -> Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(NonEmpty ([a]
as :: [a])) Int
ix' -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as
      ix :: Int
ix = Int
ix' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
  Ptr a
ptrA <- [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as
  Ptr a
ptrB <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary 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

  [a]
arrA <- Int -> Ptr a -> IO [a]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
len Ptr a
ptrA
  [a]
arrB <- Int -> Ptr a -> IO [a]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
len Ptr a
ptrB
  Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptrA
  Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptrB
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$ (a -> a -> Property) -> [a] -> [a] -> [Property]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
(===) [a]
arrA [a]
arrB

storableSetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableSetSet :: Proxy a -> Property
storableSetSet Proxy a
_ = (a -> a -> Positive Int -> Int -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> a -> Positive Int -> Int -> Property) -> Property)
-> (a -> a -> Positive Int -> Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
x :: a) (a
y :: a) (Positive Int
len) Int
ix' -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let ix :: Int
ix = Int
ix' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
  Ptr a
ptr <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary Int
len
  Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptr Int
ix a
x
  Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptr Int
ix a
y
  a
atIx <- 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
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ a
atIx a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
==== a
y

storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableList :: Proxy a -> Property
storableList Proxy a
_ = ([a] -> Property) -> Property
forall prop. Testable prop => prop -> Property
property (([a] -> Property) -> Property) -> ([a] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \([a]
as :: [a]) -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
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
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 (m :: * -> *) a. Monad m => a -> m a
return []
  [a]
asNew <- Int -> IO [a]
rebuild Int
0
  Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
ptr
  Property -> IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
as [a] -> [a] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
==== [a]
asNew)

(====) :: (Eq a, Show a) => a -> a -> Property
a
x ==== :: a -> a -> Property
==== a
y
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
x Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y = Property
forall a. a
discard
  | Bool
otherwise = a
x a -> a -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== a
y