content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE MagicHash #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeApplications #-}
  
  {-# OPTIONS_GHC -Wall #-}
  
  -- This module is almost an exact copy of the unexported module
  -- Test.QuickCheck.Classes.Prim from quickcheck-classes. We cannot depend
  -- on quickcheck-classes in the test suite since that would imply a circular
  -- dependency between primitive and quickcheck-classes. Instead, we copy
  -- this one module and then depend on quickcheck-classes-base to get
  -- everything else we need.
  module PrimLaws
    ( primLaws
    ) where
  
  import Control.Monad.Primitive (primitive_)
  import Control.Monad.ST
  import Data.Proxy (Proxy)
  import Data.Primitive.PrimArray
  import Data.Primitive.ByteArray
  import Data.Primitive.Types
  import Data.Primitive.Ptr
  import Foreign.Marshal.Alloc
  import GHC.Exts (State#, Int#, Int(I#), (+#), (<#), IsList(fromList,toList))
  
  import System.IO.Unsafe
  import Test.QuickCheck hiding ((.&.))
  
  import qualified Data.List as L
  import qualified Data.Primitive as P
  
  import Test.QuickCheck.Classes.Base (Laws(..))
  import Test.QuickCheck.Classes.Internal (isTrue#)
  
  -- | Test that a 'Prim' instance obey the several laws.
  primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
  primLaws p = Laws "Prim"
    [ ("ByteArray Put-Get (you get back what you put in)", primPutGetByteArray p)
    , ("ByteArray Get-Put (putting back what you got out has no effect)", primGetPutByteArray p)
    , ("ByteArray Put-Put (putting twice is same as putting once)", primPutPutByteArray p)
    , ("ByteArray Set Range", primSetByteArray p)
    , ("ByteArray List Conversion Roundtrips", primListByteArray p)
    , ("Ptr Put-Get (you get back what you put in)", primPutGetAddr p)
    , ("Ptr List Conversion Roundtrips", primListAddr p)
    ]
  
  primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
  primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do
    let len = L.length as
    ptr :: Ptr a <- mallocBytes (len * P.sizeOfType @a)
    let go :: Int -> [a] -> IO ()
        go !ix xs = case xs of
          [] -> return ()
          (x : xsNext) -> do
            writeOffPtr ptr ix x
            go (ix + 1) xsNext
    go 0 as
    let rebuild :: Int -> IO [a]
        rebuild !ix = if ix < len
          then (:) <$> readOffPtr ptr ix <*> rebuild (ix + 1)
          else return []
    asNew <- rebuild 0
    free ptr
    return (as == asNew)
  
  primPutGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
  primPutGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do
    ix <- choose (0,len - 1)
    return $ runST $ do
      arr <- newPrimArray len
      writePrimArray arr ix a
      a' <- readPrimArray arr ix
      return (a == a')
  
  primGetPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
  primGetPutByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do
    let arr1 = primArrayFromList as :: PrimArray a
        len = L.length as
    ix <- choose (0,len - 1)
    arr2 <- return $ runST $ do
      marr <- newPrimArray len
      copyPrimArray marr 0 arr1 0 len
      a <- readPrimArray marr ix
      writePrimArray marr ix a
      unsafeFreezePrimArray marr
    return (arr1 == arr2)
  
  primPutPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
  primPutPutByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do
    let arr1 = primArrayFromList as :: PrimArray a
        len = L.length as
    ix <- choose (0,len - 1)
    (arr2,arr3) <- return $ runST $ do
      marr2 <- newPrimArray len
      copyPrimArray marr2 0 arr1 0 len
      writePrimArray marr2 ix a
      marr3 <- newPrimArray len
      copyMutablePrimArray marr3 0 marr2 0 len
      arr2 <- unsafeFreezePrimArray marr2
      writePrimArray marr3 ix a
      arr3 <- unsafeFreezePrimArray marr3
      return (arr2,arr3)
    return (arr2 == arr3)
  
  primPutGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
  primPutGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do
    ix <- choose (0,len - 1)
    return $ unsafePerformIO $ do
      ptr :: Ptr a <- mallocBytes (len * P.sizeOfType @a)
      writeOffPtr ptr ix a
      a' <- readOffPtr ptr ix
      free ptr
      return (a == a')
  
  primSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
  primSetByteArray _ = property $ \(as :: [a]) (z :: a) -> do
    let arr1 = primArrayFromList as :: PrimArray a
        len = L.length as
    x <- choose (0,len)
    y <- choose (0,len)
    let lo = min x y
        hi = max x y
    return $ runST $ do
      marr2 <- newPrimArray len
      copyPrimArray marr2 0 arr1 0 len
      marr3 <- newPrimArray len
      copyPrimArray marr3 0 arr1 0 len
      setPrimArray marr2 lo (hi - lo) z
      internalDefaultSetPrimArray marr3 lo (hi - lo) z
      arr2 <- unsafeFreezePrimArray marr2
      arr3 <- unsafeFreezePrimArray marr3
      return (arr2 == arr3)
  
  primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
  primListByteArray _ = property $ \(as :: [a]) ->
    as == toList (fromList as :: PrimArray a)
  
  internalDefaultSetPrimArray :: Prim a
    => MutablePrimArray s a -> Int -> Int -> a -> ST s ()
  internalDefaultSetPrimArray (MutablePrimArray arr) (I# i) (I# len) ident =
    primitive_ (internalDefaultSetByteArray# arr i len ident)
  
  internalDefaultSetByteArray# :: Prim a
    => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s
  internalDefaultSetByteArray# arr# i# len# ident = go 0#
    where
    go ix# s0 = if isTrue# (ix# <# len#)
      then case writeByteArray# arr# (i# +# ix#) ident s0 of
        s1 -> go (ix# +# 1#) s1
      else s0
  