{-# 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 :: forall a. (Eq a, Show a, Storable a) => Gen a -> Laws
storableLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Storable"
  [ (String
"Set-Get (you get back what you put in)", 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)", forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableGetSet Gen a
gen)
  , (String
"List Conversion Roundtrips", 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))", 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 ", forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePokeElem Gen a
gen)
  , (String
"peekByteOff a i ≡ peek (plusPtr a i)", 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 ", 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 :: forall a. Storable a => 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 forall a. Eq a => a -> a -> Bool
== Int
len
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs
        else do
          a
x <- forall (m :: * -> *) a. MonadIO m => Gen a -> m a
sample Gen a
gen
          Int -> [a] -> f [a]
go (Int
ix forall a. Num a => a -> a -> a
+ Int
1) (a
x forall a. a -> [a] -> [a]
: [a]
xs)
  [a]
as <- forall {f :: * -> *}. MonadIO f => Int -> [a] -> f [a]
go Int
0 []
  forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as

storablePeekElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePeekElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePeekElem Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len forall a. Num a => a -> a -> a
- Int
1))
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    a
x <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
addr Int
ix
    a
y <- forall a. Storable a => Ptr a -> IO a
peek (Ptr a
addr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ix forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a)))
    forall a. Ptr a -> IO ()
free Ptr a
addr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x 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 :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePokeElem Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  a
x <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len forall a. Num a => a -> a -> a
- Int
1))
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
addr Int
ix a
x
    a
u <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
addr Int
ix
    forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr a
addr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ix forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf a
x)) a
x
    a
v <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
addr Int
ix
    forall a. Ptr a -> IO ()
free Ptr a
addr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
u 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 :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePeekByte Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len forall a. Num a => a -> a -> a
- Int
1))
  let off :: Int
off = Int
ix forall a. Num a => a -> a -> a
* (forall a. Ptr a
nullPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Storable a => a -> Int
sizeOf (forall a. [a] -> a
head [a]
as)) forall a. Ptr a -> Int -> Ptr a
`alignPtr` forall a. Storable a => a -> Int
alignment (forall a. [a] -> a
head [a]
as) forall a b. Ptr a -> Ptr b -> Int
`minusPtr` forall a. Ptr a
nullPtr
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    a
x :: a <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
addr Int
off
    a
y :: a <- forall a. Storable a => Ptr a -> IO a
peek (Ptr a
addr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
    forall a. Ptr a -> IO ()
free Ptr a
addr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x 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 :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storablePokeByte Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  a
x <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
off <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len forall a. Num a => a -> a -> a
- Int
1))
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Ptr a
addr <- forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
addr Int
off a
x
    a
u :: a <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
addr Int
off
    forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr a
addr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off) a
x
    a
v :: a <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
addr Int
off
    forall a. Ptr a -> IO ()
free Ptr a
addr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
u 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 :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableSetGet Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  a
a <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
20)
  Int
ix <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len forall a. Num a => a -> a -> a
- Int
1))
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Ptr a
ptr <- forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptr Int
ix a
a
    a
a' <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptr Int
ix
    forall a. Ptr a -> IO ()
free Ptr a
ptr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a 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 :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableGetSet Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen
  let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
  Int
ix <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
0 (Int
len forall a. Num a => a -> a -> a
- Int
1))
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Ptr a
ptrA <- forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
as
    Ptr a
ptrB <- forall a. Storable a => Gen a -> Int -> IO (Ptr a)
genArray Gen a
gen Int
len
    forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray Ptr a
ptrB Ptr a
ptrA Int
len
    a
a <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptrA Int
ix
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptrA Int
ix a
a
    Bool
res <- forall a. (Eq a, Storable a) => Ptr a -> Ptr a -> Int -> IO Bool
arrayEq Ptr a
ptrA Ptr a
ptrB Int
len
    forall a. Ptr a -> IO ()
free Ptr a
ptrA
    forall a. Ptr a -> IO ()
free Ptr a
ptrB
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
res 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 :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property
storableList Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
genSmallNonEmptyList Gen a
gen 
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
as
    Ptr a
ptr <- 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 forall a. Ord a => a -> a -> Bool
< Int
len
          then (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptr Int
ix forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO [a]
rebuild (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    [a]
asNew <- Int -> IO [a]
rebuild Int
0
    forall a. Ptr a -> IO ()
free Ptr a
ptr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as 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 :: forall a. (Eq a, Storable a) => 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 forall a. Ord a => a -> a -> Bool
< Int
len
    then do
      a
a <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptrA Int
i
      a
b <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptrB Int
i
      if a
a forall a. Eq a => a -> a -> Bool
== a
b
        then Int -> IO Bool
go (Int
i forall a. Num a => a -> a -> a
+ Int
1)
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True