    {-# 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