{-# 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 :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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 :: forall a. (Arbitrary a, Storable a) => 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 :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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
  addr :: Ptr a <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary Int
len
  x <- peekElemOff addr ix
  y <- peek (addr `advancePtr` ix)
  free addr
  return (x ==== y)

storablePokeElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storablePokeElem :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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
  addr <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary Int
len
  pokeElemOff addr ix x
  u <- peekElemOff addr ix
  poke (addr `advancePtr` ix) x
  v <- peekElemOff addr ix
  free addr
  return (u ==== v)

storablePeekByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storablePeekByte :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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)
  addr :: Ptr a <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary Int
len
  x :: a <- peekByteOff addr off
  y :: a <- peek (addr `plusPtr` off)
  free addr
  return (x ==== y)

storablePokeByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storablePokeByte :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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)
  addr :: Ptr a <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary Int
len
  pokeByteOff addr off x
  u :: a <- peekByteOff addr off
  poke (addr `plusPtr` off) x
  v :: a <- peekByteOff addr off
  free addr
  return (u ==== v)

storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableSetGet :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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 <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary Int
len
  pokeElemOff ptr ix a
  a' <- peekElemOff ptr ix
  free ptr
  return (a ==== a')

storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableGetSet :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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 a. [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
  ptrA <- [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as
  ptrB <- arrayArbitrary len
  copyArray ptrB ptrA len
  a <- peekElemOff ptrA ix
  pokeElemOff ptrA ix a

  arrA <- peekArray len ptrA
  arrB <- peekArray len ptrB
  free ptrA
  free ptrB
  return $ conjoin $ zipWith (===) arrA arrB

storableSetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableSetSet :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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 <- Int -> IO (Ptr a)
forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)
arrayArbitrary Int
len
  pokeElemOff ptr ix x
  pokeElemOff ptr ix y
  atIx <- peekElemOff ptr ix
  free ptr
  return $ atIx ==== y

storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableList :: forall a.
(Storable a, Eq a, Arbitrary a, Show a) =>
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as
  ptr <- [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as
  let 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 a b. IO (a -> b) -> IO a -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  asNew <- rebuild 0
  free ptr
  return (as ==== asNew)

(====) :: (Eq a, Show a) => a -> a -> Property
a
x ==== :: forall a. (Eq a, Show a) => 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