{-# language CPP #-}
{-# language LambdaCase #-}
{-# language UnboxedTuples #-}
{-# language TypeApplications #-}
{-# language MagicHash #-}
{-# language BangPatterns #-}
{-# language ScopedTypeVariables #-}

#ifndef HAVE_PRIMITIVE

module Hedgehog.Classes.Prim () where

#else

module Hedgehog.Classes.Prim (primLaws) where

import Control.Monad (when)
import Foreign.Marshal.Alloc
import GHC.Exts hiding (setByteArray#)

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Primitive
import Data.Primitive
import Data.Primitive.Ptr

import Hedgehog
import Hedgehog.Classes.Common
import Hedgehog.Internal.Gen (sample)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

-- | Tests the following 'Prim' laws:
--
-- [__ByteArray Set-Get__]: @'primitive_' ('writeByteArray#' ba# ix# x) '*>' 'primitive' ('readByteArray#' ba# ix#)@ ≡ @'pure' x@
-- [__ByteArray Get-Set__]: @'primitive' ('readByteArray#' ba# ix#) '>>=' \x -> 'primitive_' ('writeByteArray#' ba# ix# x)@ ≡ @'pure' ()@
-- [__ByteArray Set-Set__]: @'primitive_' ('writeByteArray#' ba# ix# x) *> 'primitive_' ('writeByteArray#' ba# ix# x)@ ≡ @'primitive_' ('writeByteArray#' ba# ix# x)@
-- [__ByteArray Set Range__]: The behavior of 'setByteArray#' matches the default implementation
-- [__ByteArray List Conversion Roundtrips__]: Turning a list into a 'PrimArray' and back gives you the same list
-- [__Addr Set-Get__]: @'primitive_' ('writeOffAddr#' addr# ix# x) '*>' 'primitive' ('readOffAddr#' addr# ix#)@ ≡ @'pure' x@
-- [__Addr Get-Set__]: @'primitive' ('readOffAddr#' addr# ix#) '>>=' \x -> 'primitive_' ('writeOffAddr#' addr# ix# x)@ ≡ @'pure' ()@
-- [__Addr Set-Set__]: @'primitive_' ('writeOffAddr#' addr# ix# x) '*>' 'primitive_' ('writeOffAddr#' addr# ix# x)@ ≡ @'primitive_' ('writeOffAddr#' addr# ix# x)@
-- [__Addr Set Range__]: The behavior of 'setOffAddr#' matches the default implementation
-- [__Addr List Conversion Roundtrips__]: Mallocing a list and then reconstructing it gives you the same list
primLaws :: (Prim a, Eq a, Show a) => Gen a -> Laws
primLaws :: forall a. (Prim a, Eq a, Show a) => Gen a -> Laws
primLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Prim"
  [ (String
"ByteArray Set-Get (you get back what you put in)", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetGetByteArray Gen a
gen)
  , (String
"ByteArray Get-Set (putting back what you got out has no effect)", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primGetSetByteArray Gen a
gen)
  , (String
"ByteArray Set-Set (putting twice is the same as putting once)", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetSetByteArray Gen a
gen)
  , (String
"ByteArray Set Range", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetByteArray Gen a
gen)
  , (String
"ByteArray List Conversion Roundtrips", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primListRoundtripByteArray Gen a
gen)
  , (String
"Addr Set-Get (you get back what you put in)", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetGetAddr Gen a
gen)
  , (String
"Addr Get-Set (putting back what you got out has no effect)", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primGetSetAddr Gen a
gen)
  , (String
"Addr Set-Set (putting twice is the same as putting once)", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetSetAddr Gen a
gen)
  , (String
"Addr Set Range", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetRangeAddr Gen a
gen)
  , (String
"Addr List Conversion Roundtrips", forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primListRoundtripAddr Gen a
gen)
  ]

genSmallArrayLen :: Gen Int
genSmallArrayLen :: Gen Int
genSmallArrayLen = forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
10)

genMutPrimArray :: Prim a => Gen a -> Int -> IO (MutablePrimArray (PrimState IO) a)
genMutPrimArray :: forall a.
Prim a =>
Gen a -> Int -> IO (MutablePrimArray (PrimState IO) a)
genMutPrimArray Gen a
gen Int
len = do
  MutablePrimArray RealWorld a
marr <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
  let go :: Int -> IO ()
      go :: Int -> IO ()
go !Int
ix = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix forall a. Ord a => a -> a -> Bool
< Int
len) forall a b. (a -> b) -> a -> b
$ do
        forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
marr Int
ix forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => Gen a -> m a
sample Gen a
gen
        Int -> IO ()
go (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
  Int -> IO ()
go Int
0
  forall (f :: * -> *) a. Applicative f => a -> f a
pure MutablePrimArray RealWorld a
marr

genPrimArray :: forall a. Prim a => Gen a -> Int -> IO (PrimArray a)
genPrimArray :: forall a. Prim a => Gen a -> Int -> IO (PrimArray a)
genPrimArray Gen a
gen Int
len = forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
Prim a =>
Gen a -> Int -> IO (MutablePrimArray (PrimState IO) a)
genMutPrimArray Gen a
gen Int
len

-- | Setting an element and getting it back should give back the same element
primSetGetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property
primSetGetByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetGetByteArray Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  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))
  a
el <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  a
el' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    MutablePrimArray RealWorld a
marr <- forall a.
Prim a =>
Gen a -> Int -> IO (MutablePrimArray (PrimState IO) a)
genMutPrimArray Gen a
gen Int
len
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
marr Int
ix a
el
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
marr Int
ix
  a
el forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
el'

-- | Getting an element and putting it back should not change the array
primGetSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property
primGetSetByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primGetSetByteArray Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  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))
  (PrimArray a
arr1, PrimArray a
arr2) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    PrimArray a
arr1 <- forall a. Prim a => Gen a -> Int -> IO (PrimArray a)
genPrimArray Gen a
gen Int
len
    MutablePrimArray RealWorld a
marr2 <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
marr2 Int
0 PrimArray a
arr1 Int
0 Int
len
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
marr2 Int
ix forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
marr2 Int
ix
    PrimArray a
arr2 <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
marr2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray a
arr1, PrimArray a
arr2)
  PrimArray a
arr1 forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== PrimArray a
arr2

-- | Setting and element once and twice should result in the same array (setting
-- should be idempotent)
primSetSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property
primSetSetByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetSetByteArray Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  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))
  a
el <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  (PrimArray a
arr1, PrimArray a
arr2) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    MutablePrimArray RealWorld a
marr1 <- forall a.
Prim a =>
Gen a -> Int -> IO (MutablePrimArray (PrimState IO) a)
genMutPrimArray Gen a
gen Int
len
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
marr1 Int
ix a
el
    MutablePrimArray RealWorld a
marr2 <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> MutablePrimArray (PrimState m) a -> Int -> Int -> m ()
copyMutablePrimArray MutablePrimArray RealWorld a
marr2 Int
0 MutablePrimArray RealWorld a
marr1 Int
0 Int
len
    PrimArray a
arr1 <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
marr1
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
marr2 Int
ix a
el
    PrimArray a
arr2 <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
marr2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray a
arr1, PrimArray a
arr2)
  PrimArray a
arr1 forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== PrimArray a
arr2

-- | Setting a range should match the default implementation
primSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property
primSetByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetByteArray Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  (Int
low, Int
high) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b}. Ord b => (b, b) -> (b, b)
order forall a b. (a -> b) -> a -> b
$ (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (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)))
  a
el <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  (PrimArray a
arr2, PrimArray a
arr3) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    PrimArray a
arr1 <- forall a. Prim a => Gen a -> Int -> IO (PrimArray a)
genPrimArray Gen a
gen Int
len
    MutablePrimArray RealWorld a
marr2 <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
marr2 Int
0 PrimArray a
arr1 Int
0 Int
len
    MutablePrimArray RealWorld a
marr3 <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
marr3 Int
0 PrimArray a
arr1 Int
0 Int
len
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()
setPrimArray MutablePrimArray RealWorld a
marr2 Int
low (Int
high forall a. Num a => a -> a -> a
- Int
low) a
el
    PrimArray a
arr2 <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
marr2
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()
defaultSetPrimArray MutablePrimArray RealWorld a
marr3 Int
low (Int
high forall a. Num a => a -> a -> a
- Int
low) a
el
    PrimArray a
arr3 <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
marr3
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray a
arr2, PrimArray a
arr3)
  PrimArray a
arr2 forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== PrimArray a
arr3
  where
    order :: (b, b) -> (b, b)
order (b
x, b
y) = if b
x forall a. Ord a => a -> a -> Bool
< b
y then (b
x, b
y) else (b
y, b
x)

defaultSetPrimArray :: (Prim a, PrimMonad m)
  => MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()
defaultSetPrimArray :: forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()
defaultSetPrimArray (MutablePrimArray MutableByteArray# (PrimState m)
marr#) (I# Int#
off#) (I# Int#
len#) a
x = forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (Int# -> State# (PrimState m) -> State# (PrimState m)
go Int#
off#)
  where
    end# :: Int#
end# = Int#
off# Int# -> Int# -> Int#
+# Int#
len#
    go :: Int# -> State# (PrimState m) -> State# (PrimState m)
go !Int#
ix# State# (PrimState m)
s# = if Int# -> Bool
isTrue# (Int#
ix# Int# -> Int# -> Int#
>=# Int#
end#)
      then State# (PrimState m)
s#
      else case forall a s.
Prim a =>
MutableByteArray# s -> Int# -> a -> State# s -> State# s
writeByteArray# MutableByteArray# (PrimState m)
marr# Int#
ix# a
x State# (PrimState m)
s# of
        State# (PrimState m)
s2# -> Int# -> State# (PrimState m) -> State# (PrimState m)
go (Int#
ix# Int# -> Int# -> Int#
+# Int#
1#) State# (PrimState m)
s2#

-- | @'toList' . 'fromList'@ should result in the same list
primListRoundtripByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primListRoundtripByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primListRoundtripByteArray Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
xs <- 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]
xs forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall l. IsList l => l -> [Item l]
toList (forall l. IsList l => [Item l] -> l
fromList [a]
xs :: PrimArray a)

withBytes :: forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes :: forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len Ptr a -> IO b
h = do
  Ptr a
p <- forall a. Int -> IO (Ptr a)
mallocBytes (Int
len forall a. Num a => a -> a -> a
* forall a. Prim a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a))
  Ptr a -> IO b
h Ptr a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Ptr a -> IO ()
free Ptr a
p

ptrToPrimArray :: forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)
ptrToPrimArray :: forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)
ptrToPrimArray Ptr a
p Int
len = do
  MutablePrimArray RealWorld a
marr <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
  forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> Int -> Ptr a -> Int -> m ()
copyPtrToMutablePrimArray MutablePrimArray RealWorld a
marr Int
0 Ptr a
p Int
len
  forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
marr

-- | Setting an element and getting it back should give back the same element
primSetGetAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetGetAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetGetAddr Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  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))
  a
el <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  a
el' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr a
p -> do
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> a -> m ()
writeOffPtr Ptr a
p Int
ix a
el
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> m a
readOffPtr Ptr a
p Int
ix
  a
el forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
el'

-- | Getting an element and putting it back should not change the array
primGetSetAddr :: (Eq a, Show a, Prim a) => Gen a -> Property
primGetSetAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primGetSetAddr Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  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))
  (PrimArray a
arr1, PrimArray a
arr2) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    PrimArray a
arr1 <- forall a. Prim a => Gen a -> Int -> IO (PrimArray a)
genPrimArray Gen a
gen Int
len
    PrimArray a
arr2 <- forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr a
p -> do
      forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Ptr a -> PrimArray a -> Int -> Int -> m ()
copyPrimArrayToPtr Ptr a
p PrimArray a
arr1 Int
0 Int
len
      forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> a -> m ()
writeOffPtr Ptr a
p Int
ix forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> m a
readOffPtr Ptr a
p Int
ix
      forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)
ptrToPrimArray Ptr a
p Int
len
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray a
arr1, PrimArray a
arr2)
  PrimArray a
arr1 forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== PrimArray a
arr2

-- | Setting and element once and twice should result in the same array (setting
-- should be idempotent)
primSetSetAddr :: (Eq a, Show a, Prim a) => Gen a -> Property
primSetSetAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetSetAddr Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  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))
  a
el <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  (PrimArray a
arr2, PrimArray a
arr3) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    PrimArray a
arr1 <- forall a. Prim a => Gen a -> Int -> IO (PrimArray a)
genPrimArray Gen a
gen Int
len
    forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr a
p1 -> do
      forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Ptr a -> PrimArray a -> Int -> Int -> m ()
copyPrimArrayToPtr Ptr a
p1 PrimArray a
arr1 Int
0 Int
len
      forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> a -> m ()
writeOffPtr Ptr a
p1 Int
ix a
el
      PrimArray a
arr2 <- forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)
ptrToPrimArray Ptr a
p1 Int
len
      forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr a
p2 -> do
        forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Ptr a -> PrimArray a -> Int -> Int -> m ()
copyPrimArrayToPtr Ptr a
p2 PrimArray a
arr2 Int
0 Int
len
        forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> a -> m ()
writeOffPtr Ptr a
p2 Int
ix a
el
        PrimArray a
arr3 <- forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)
ptrToPrimArray Ptr a
p2 Int
len
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray a
arr2, PrimArray a
arr3)
  PrimArray a
arr2 forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== PrimArray a
arr3

-- | Setting a range should match the default implementation
primSetRangeAddr :: (Eq a, Show a, Prim a) => Gen a -> Property
primSetRangeAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primSetRangeAddr Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Int
len <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Int
genSmallArrayLen
  (Int
low, Int
high) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b}. Ord b => (b, b) -> (b, b)
order forall a b. (a -> b) -> a -> b
$ (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (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)))
  a
el <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  (PrimArray a
arr2, PrimArray a
arr3) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr a
p1 -> do
      forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr a
p2 -> do
        PrimArray a
arr1 <- forall a. Prim a => Gen a -> Int -> IO (PrimArray a)
genPrimArray Gen a
gen Int
len
        forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Ptr a -> PrimArray a -> Int -> Int -> m ()
copyPrimArrayToPtr Ptr a
p1 PrimArray a
arr1 Int
0 Int
len
        forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Ptr a -> PrimArray a -> Int -> Int -> m ()
copyPrimArrayToPtr Ptr a
p2 PrimArray a
arr1 Int
0 Int
len
        forall {m :: * -> *} {a} {a}.
(PrimMonad m, Prim a) =>
Ptr a -> Int -> Int -> a -> m ()
setOffPtr Ptr a
p1 Int
low (Int
high forall a. Num a => a -> a -> a
- Int
low) a
el
        PrimArray a
arr2 <- forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)
ptrToPrimArray Ptr a
p1 Int
len
        forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> Int -> a -> m ()
defaultSetOffAddr Ptr a
p2 Int
low (Int
high forall a. Num a => a -> a -> a
- Int
low) a
el
        PrimArray a
arr3 <- forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)
ptrToPrimArray Ptr a
p2 Int
len
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray a
arr2, PrimArray a
arr3)
  PrimArray a
arr2 forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== PrimArray a
arr3
  where
    order :: (b, b) -> (b, b)
order (b
x, b
y) = if b
x forall a. Ord a => a -> a -> Bool
< b
y then (b
x, b
y) else (b
y, b
x)
    setOffPtr :: Ptr a -> Int -> Int -> a -> m ()
setOffPtr (Ptr Addr#
addr#) (I# Int#
off#) (I# Int#
len#) a
x =
      forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (forall a s.
Prim a =>
Addr# -> Int# -> Int# -> a -> State# s -> State# s
setOffAddr# Addr#
addr# Int#
off# Int#
len# a
x)

defaultSetOffAddr :: (Prim a, PrimMonad m) => Ptr a -> Int -> Int -> a -> m ()
defaultSetOffAddr :: forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> Int -> a -> m ()
defaultSetOffAddr (Ptr Addr#
addr#) (I# Int#
off#) (I# Int#
len#) a
x = forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (forall {s}. Int# -> State# s -> State# s
go Int#
off#)
  where
    end# :: Int#
end# = Int#
off# Int# -> Int# -> Int#
+# Int#
len#
    go :: Int# -> State# s -> State# s
go !Int#
ix# State# s
s# = if Int# -> Bool
isTrue# (Int#
ix# Int# -> Int# -> Int#
>=# Int#
end#)
      then State# s
s#
      else case forall a s. Prim a => Addr# -> Int# -> a -> State# s -> State# s
writeOffAddr# Addr#
addr# Int#
ix# a
x State# s
s# of
        State# s
s2# -> Int# -> State# s -> State# s
go (Int#
ix# Int# -> Int# -> Int#
+# Int#
1#) State# s
s2#

-- | Mallocing an array, emptying a list into the array, and then rebuilding the
-- list from that array should produce the original list.
primListRoundtripAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primListRoundtripAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property
primListRoundtripAddr Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
xs <- 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]
genSmallList Gen a
gen
  let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
  [a]
xs' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b
withBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr a
p -> do
    let listToPtr :: Int -> [a] -> IO ()
        listToPtr :: Int -> [a] -> IO ()
listToPtr !Int
ix = \case
          [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          (a
y:[a]
ys) -> forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> a -> m ()
writeOffPtr Ptr a
p Int
ix a
y forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> [a] -> IO ()
listToPtr (Int
ix forall a. Num a => a -> a -> a
+ Int
1) [a]
ys
    let ptrToList :: Int -> IO [a]
        ptrToList :: Int -> IO [a]
ptrToList !Int
ix =
          if Int
ix forall a. Ord a => a -> a -> Bool
>= Int
len
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            else (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
Ptr a -> Int -> m a
readOffPtr Ptr a
p Int
ix forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO [a]
ptrToList (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
    Int -> [a] -> IO ()
listToPtr Int
0 [a]
xs
    Int -> IO [a]
ptrToList Int
0
  [a]
xs forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== [a]
xs'

#endif