module Test.QuickCheck.Classes
(
lawsCheck
, lawsCheckMany
, commutativeMonoidLaws
, eqLaws
, ordLaws
, showReadLaws
, jsonLaws
, integralLaws
, jsonLaws
, monoidLaws
, ordLaws
, primLaws
, semigroupLaws
, showReadLaws
, storableLaws
, integralLaws
#if MIN_VERSION_base(4,7,0)
, bitsLaws
, isListLaws
#endif
#if MIN_VERSION_QuickCheck(2,10,0)
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
, altLaws
, alternativeLaws
, applicativeLaws
, foldableLaws
, functorLaws
, monadLaws
#endif
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
, bifunctorLaws
#endif
#endif
, Laws(..)
) where
import Data.Functor ((<$))
import Control.Applicative (liftA2,(<*>),pure,Applicative,(<$>),Alternative(..))
import Control.Monad.ST
import Data.Aeson (FromJSON(..),ToJSON(..))
import Data.Bifunctor (Bifunctor(..))
import Data.Bits
import Data.Foldable (foldMap,Foldable)
import Data.Monoid (Monoid,mconcat,mempty,mappend)
import Data.Primitive hiding (sizeOf,newArray,copyArray)
import Data.Primitive.Addr (Addr(..))
import Data.Proxy
import Data.Semigroup (Semigroup)
import Data.Functor.Alt hiding (Apply)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Storable
import GHC.Exts (Int(I#),(*#),newByteArray#,unsafeFreezeByteArray#,
copyMutableByteArray#,copyByteArray#,quotInt#,sizeofByteArray#)
import GHC.Ptr (Ptr(..))
import System.IO.Unsafe
import Test.QuickCheck hiding ((.&.))
import Test.QuickCheck.Property (Property(..))
import Control.Monad.Primitive (PrimMonad,PrimState,primitive,primitive_)
import qualified Data.Aeson as AE
import qualified Data.Primitive as P
import qualified Data.Semigroup as SG
import qualified Data.List as L
import qualified Data.Set as S
#if MIN_VERSION_base(4,6,0)
import Text.Read (readMaybe)
#endif
#if MIN_VERSION_base(4,7,0)
import GHC.Exts (IsList(fromList,toList,fromListN),Item,
copyByteArrayToAddr#,copyAddrToByteArray#)
#endif
#if MIN_VERSION_QuickCheck(2,10,0)
import Control.Exception (ErrorCall,try,evaluate)
import Control.Monad (ap)
import Control.Monad.Trans.Class (lift)
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
import Data.Functor.Classes
#endif
import Test.QuickCheck.Arbitrary (Arbitrary1(..))
import Test.QuickCheck.Monadic (monadicIO)
import qualified Data.Foldable as F
#endif
data Laws = Laws
{ lawsTypeclass :: String
, lawsProperties :: [(String,Property)]
}
lawsCheck :: Laws -> IO ()
lawsCheck (Laws className properties) = do
flip foldMapA properties $ \(name,p) -> do
putStr (className ++ ": " ++ name ++ " ")
quickCheck p
lawsCheckMany ::
[(String,[Laws])]
-> IO ()
lawsCheckMany xs = do
putStrLn "Testing properties for common typeclasses"
r <- flip foldMapA xs $ \(typeName,laws) -> do
putStrLn $ "------------"
putStrLn $ "-- " ++ typeName
putStrLn $ "------------"
flip foldMapA laws $ \(Laws typeClassName properties) -> do
flip foldMapA properties $ \(name,p) -> do
putStr (typeClassName ++ ": " ++ name ++ " ")
r <- quickCheckResult p
return $ case r of
Success _ _ _ -> Good
_ -> Bad
putStrLn ""
case r of
Good -> putStrLn "All tests succeeded"
Bad -> putStrLn "One or more tests failed"
data Status = Bad | Good
instance Semigroup Status where
Good <> x = x
Bad <> _ = Bad
instance Monoid Status where
mempty = Good
mappend = (SG.<>)
newtype Ap f a = Ap { getAp :: f a }
instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
Ap x <> Ap y = Ap $ liftA2 (SG.<>) x y
instance (Applicative f, Monoid a, Semigroup a) => Monoid (Ap f a) where
mempty = Ap $ pure mempty
mappend = (SG.<>)
foldMapA :: (Foldable t, Monoid m, Semigroup m, Applicative f) => (a -> f m) -> t a -> f m
foldMapA f = getAp . foldMap (Ap . f)
jsonLaws :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> Laws
jsonLaws p = Laws "ToJSON/FromJSON"
[ ("Partial Isomorphism", jsonEncodingPartialIsomorphism p)
, ("Encoding Equals Value", jsonEncodingEqualsValue p)
]
#if MIN_VERSION_base(4,7,0)
isListLaws :: (IsList a, Show a, Show (Item a), Arbitrary a, Arbitrary (Item a), Eq a) => Proxy a -> Laws
isListLaws p = Laws "IsList"
[ ("Partial Isomorphism", isListPartialIsomorphism p)
, ("Length Preservation", isListLengthPreservation p)
]
#endif
showReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> Laws
showReadLaws p = Laws "Show/Read"
[ ("Partial Isomorphism", showReadPartialIsomorphism p)
]
semigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
semigroupLaws p = Laws "Semigroup"
[ ("Associative", semigroupAssociative p)
]
eqLaws :: (Eq a, Arbitrary a, Show a) => Proxy a -> Laws
eqLaws p = Laws "Eq"
[ ("Transitive", eqTransitive p)
, ("Symmetric", eqSymmetric p)
, ("Reflexive", eqReflexive p)
]
ordLaws :: (Ord a, Arbitrary a, Show a) => Proxy a -> Laws
ordLaws p = Laws "Ord"
[ ("Antisymmetry", ordAntisymmetric p)
, ("Transitivity", ordTransitive p)
, ("Totality", ordTotal p)
]
monoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
monoidLaws p = Laws "Monoid"
[ ("Associative", monoidAssociative p)
, ("Left Identity", monoidLeftIdentity p)
, ("Right Identity", monoidRightIdentity p)
]
commutativeMonoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
commutativeMonoidLaws p = Laws "Commutative Monoid" $ lawsProperties (monoidLaws p) ++
[ ("Commutative", monoidCommutative p)
]
integralLaws :: (Integral a, Arbitrary a, Show a) => Proxy a -> Laws
integralLaws p = Laws "Integral"
[ ("Quotient Remainder", integralQuotientRemainder p)
, ("Division Modulus", integralDivisionModulus p)
, ("Integer Roundtrip", integralIntegerRoundtrip p)
]
#if MIN_VERSION_base(4,7,0)
bitsLaws :: (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Laws
bitsLaws p = Laws "Bits"
[ ("Conjunction Idempotence", bitsConjunctionIdempotence p)
, ("Disjunction Idempotence", bitsDisjunctionIdempotence p)
, ("Double Complement", bitsDoubleComplement p)
, ("Set Bit", bitsSetBit p)
, ("Clear Bit", bitsClearBit p)
, ("Complement Bit", bitsComplementBit p)
, ("Clear Zero", bitsClearZero p)
, ("Set Zero", bitsSetZero p)
, ("Test Zero", bitsTestZero p)
, ("Pop Zero", bitsPopZero p)
#if MIN_VERSION_base(4,8,0)
, ("Count Leading Zeros of Zero", bitsCountLeadingZeros p)
, ("Count Trailing Zeros of Zero", bitsCountTrailingZeros p)
#endif
]
#endif
primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
primLaws p = Laws "Prim"
[ ("ByteArray Set-Get (you get back what you put in)", primSetGetByteArray p)
, ("ByteArray Get-Set (putting back what you got out has no effect)", primGetSetByteArray p)
, ("ByteArray Set-Set (setting twice is same as setting once)", primSetSetByteArray p)
#if MIN_VERSION_base(4,7,0)
, ("ByteArray List Conversion Roundtrips", primListByteArray p)
#endif
, ("Addr Set-Get (you get back what you put in)", primSetGetAddr p)
, ("Addr Get-Set (putting back what you got out has no effect)", primGetSetAddr p)
, ("Addr List Conversion Roundtrips", primListAddr p)
]
storableLaws :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
storableLaws p = Laws "Storable"
[ ("Set-Get (you get back what you put in)", storableSetGet p)
, ("Get-Set (putting back what you got out has no effect)", storableGetSet p)
, ("List Conversion Roundtrips", storableList p)
]
#if MIN_VERSION_base(4,7,0)
isListPartialIsomorphism :: forall a. (IsList a, Show a, Arbitrary a, Eq a) => Proxy a -> Property
isListPartialIsomorphism _ = myForAllShrink False (const True)
(\(a :: a) -> ["a = " ++ show a])
"fromList (toList a)"
(\a -> fromList (toList a))
"a"
(\a -> a)
isListLengthPreservation :: forall a. (IsList a, Show (Item a), Arbitrary (Item a), Eq a) => Proxy a -> Property
isListLengthPreservation _ = property $ \(xs :: [Item a]) ->
(fromList xs :: a) == fromListN (length xs) xs
#endif
showReadPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property
showReadPartialIsomorphism _ = property $ \(a :: a) ->
#if MIN_VERSION_base(4,6,0)
readMaybe (show a) == Just a
#else
read (show a) == a
#endif
jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a, Arbitrary a) => Proxy a -> Property
jsonEncodingEqualsValue _ = property $ \(a :: a) ->
case AE.decode (AE.encode a) of
Nothing -> False
Just (v :: AE.Value) -> v == toJSON a
jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a, Arbitrary a) => Proxy a -> Property
jsonEncodingPartialIsomorphism _ = property $ \(a :: a) ->
AE.decode (AE.encode a) == Just a
eqTransitive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property
eqTransitive _ = property $ \(a :: a) b c -> case a == b of
True -> case b == c of
True -> a == c
False -> a /= c
False -> case b == c of
True -> a /= c
False -> True
ordAntisymmetric :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property
ordAntisymmetric _ = property $ \(a :: a) b -> ((a <= b) && (b <= a)) == (a == b)
ordTotal :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property
ordTotal _ = property $ \(a :: a) b -> ((a <= b) || (b <= a)) == True
ordTransitive :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property
ordTransitive _ = property $ \(a :: a) b c -> case (compare a b, compare b c) of
(LT,LT) -> a < c
(LT,EQ) -> a < c
(LT,GT) -> True
(EQ,LT) -> a < c
(EQ,EQ) -> a == c
(EQ,GT) -> a > c
(GT,LT) -> True
(GT,EQ) -> a > c
(GT,GT) -> a > c
eqSymmetric :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property
eqSymmetric _ = property $ \(a :: a) b -> case a == b of
True -> b == a
False -> b /= a
eqReflexive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property
eqReflexive _ = property $ \(a :: a) -> a == a
semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
semigroupAssociative _ = property $ \(a :: a) b c -> a SG.<> (b SG.<> c) == (a SG.<> b) SG.<> c
monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidAssociative _ = myForAllShrink True (const True)
(\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c])
"mappend a (mappend b c)"
(\(a,b,c) -> mappend a (mappend b c))
"mappend (mappend a b) c"
(\(a,b,c) -> mappend (mappend a b) c)
monoidLeftIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidLeftIdentity _ = myForAllShrink False (const True)
(\(a :: a) -> ["a = " ++ show a])
"mappend mempty a"
(\a -> mappend mempty a)
"a"
(\a -> a)
monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidRightIdentity _ = myForAllShrink False (const True)
(\(a :: a) -> ["a = " ++ show a])
"mappend a mempty"
(\a -> mappend a mempty)
"a"
(\a -> a)
#if MIN_VERSION_base(4,7,0)
bitsConjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property
bitsConjunctionIdempotence _ = myForAllShrink False (const True)
(\(n :: a) -> ["n = " ++ show n])
"n .&. n"
(\n -> n .&. n)
"n"
(\n -> n)
bitsDisjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property
bitsDisjunctionIdempotence _ = myForAllShrink False (const True)
(\(n :: a) -> ["n = " ++ show n])
"n .|. n"
(\n -> n .|. n)
"n"
(\n -> n)
bitsDoubleComplement :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property
bitsDoubleComplement _ = myForAllShrink False (const True)
(\(n :: a) -> ["n = " ++ show n])
"complement (complement n)"
(\n -> complement (complement n))
"n"
(\n -> n)
bitsSetBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property
bitsSetBit _ = myForAllShrink True (const True)
(\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i])
"setBit n i"
(\(n,BitIndex i) -> setBit n i)
"n .|. bit i"
(\(n,BitIndex i) -> n .|. bit i)
bitsClearBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property
bitsClearBit _ = myForAllShrink True (const True)
(\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i])
"clearBit n i"
(\(n,BitIndex i) -> clearBit n i)
"n .&. complement (bit i)"
(\(n,BitIndex i) -> n .&. complement (bit i))
bitsComplementBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property
bitsComplementBit _ = myForAllShrink True (const True)
(\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i])
"complementBit n i"
(\(n,BitIndex i) -> complementBit n i)
"xor n (bit i)"
(\(n,BitIndex i) -> xor n (bit i))
bitsClearZero :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property
bitsClearZero _ = myForAllShrink False (const True)
(\(n :: a) -> ["n = " ++ show n])
"complement (complement n)"
(\n -> complement (complement n))
"n"
(\n -> n)
bitsSetZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property
bitsSetZero _ = myForAllShrink True (const True)
(\(BitIndex i :: BitIndex a) -> ["i = " ++ show i])
"setBit zeroBits i"
(\(BitIndex i) -> setBit (zeroBits :: a) i)
"bit i"
(\(BitIndex i) -> bit i)
bitsTestZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property
bitsTestZero _ = myForAllShrink True (const True)
(\(BitIndex i :: BitIndex a) -> ["i = " ++ show i])
"testBit zeroBits i"
(\(BitIndex i) -> testBit (zeroBits :: a) i)
"False"
(\_ -> False)
bitsPopZero :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property
bitsPopZero _ = myForAllShrink True (const True)
(\() -> [])
"popCount zeroBits"
(\() -> popCount (zeroBits :: a))
"0"
(\() -> 0)
#endif
#if MIN_VERSION_base(4,8,0)
bitsCountLeadingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property
bitsCountLeadingZeros _ = myForAllShrink True (const True)
(\() -> [])
"countLeadingZeros zeroBits"
(\() -> countLeadingZeros (zeroBits :: a))
"finiteBitSize undefined"
(\() -> finiteBitSize (undefined :: a))
bitsCountTrailingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property
bitsCountTrailingZeros _ = myForAllShrink True (const True)
(\() -> [])
"countTrailingZeros zeroBits"
(\() -> countTrailingZeros (zeroBits :: a))
"finiteBitSize undefined"
(\() -> finiteBitSize (undefined :: a))
#endif
integralQuotientRemainder :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property
integralQuotientRemainder _ = myForAllShrink False (\(_,y) -> y /= 0)
(\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y])
"(quot x y) * y + (rem x y)"
(\(x,y) -> (quot x y) * y + (rem x y))
"x"
(\(x,_) -> x)
integralDivisionModulus :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property
integralDivisionModulus _ = myForAllShrink False (\(_,y) -> y /= 0)
(\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y])
"(div x y) * y + (mod x y)"
(\(x,y) -> (div x y) * y + (mod x y))
"x"
(\(x,_) -> x)
integralIntegerRoundtrip :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property
integralIntegerRoundtrip _ = myForAllShrink False (const True)
(\(x :: a) -> ["x = " ++ show x])
"fromInteger (toInteger x)"
(\x -> fromInteger (toInteger x))
"x"
(\x -> x)
monoidCommutative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
monoidCommutative _ = myForAllShrink True (const True)
(\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b])
"mappend a b"
(\(a,b) -> mappend a b)
"mappend b a"
(\(a,b) -> mappend b a)
#if MIN_VERSION_base(4,7,0)
primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
primListByteArray _ = property $ \(as :: [a]) ->
as == toList (fromList as :: PrimArray a)
#endif
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 addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))
let addr = Addr addr#
let go :: Int -> [a] -> IO ()
go !ix xs = case xs of
[] -> return ()
(x : xsNext) -> do
writeOffAddr addr ix x
go (ix + 1) xsNext
go 0 as
let rebuild :: Int -> IO [a]
rebuild !ix = if ix < len
then (:) <$> readOffAddr addr ix <*> rebuild (ix + 1)
else return []
asNew <- rebuild 0
free ptr
return (as == asNew)
primSetGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
primSetGetByteArray _ = 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')
primGetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
primGetSetByteArray _ = 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)
primSetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
primSetSetByteArray _ = 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)
primSetGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
primSetGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do
ix <- choose (0,len 1)
return $ unsafePerformIO $ do
ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))
let addr = Addr addr#
writeOffAddr addr ix a
a' <- readOffAddr addr ix
free ptr
return (a == a')
primGetSetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
primGetSetAddr _ = 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 $ unsafePerformIO $ do
ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))
let addr = Addr addr#
copyPrimArrayToPtr ptr arr1 0 len
a :: a <- readOffAddr addr ix
writeOffAddr addr ix a
marr <- newPrimArray len
copyPtrToMutablePrimArray marr 0 ptr len
free ptr
unsafeFreezePrimArray marr
return (arr1 == arr2)
storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableSetGet _ = property $ \(a :: a) len -> (len > 0) ==> do
ix <- choose (0,len 1)
return $ unsafePerformIO $ do
ptr :: Ptr a <- mallocArray 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 _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do
let len = L.length as
ix <- choose (0,len 1)
return $ unsafePerformIO $ do
ptrA <- newArray as
ptrB <- mallocArray len
copyArray ptrB ptrA len
a <- peekElemOff ptrA ix
pokeElemOff ptrA ix a
res <- arrayEq ptrA ptrB len
free ptrA
free ptrB
return res
storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
storableList _ = property $ \(as :: [a]) -> unsafePerformIO $ do
let len = L.length as
ptr <- newArray as
let rebuild :: Int -> IO [a]
rebuild !ix = if ix < len
then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1)
else return []
asNew <- rebuild 0
free ptr
return (as == asNew)
arrayEq :: forall a. (Storable a, Eq a) => Ptr a -> Ptr a -> Int -> IO Bool
arrayEq ptrA ptrB len = go 0 where
go !i = if i < len
then do
a <- peekElemOff ptrA i
b <- peekElemOff ptrB i
if a == b
then go (i + 1)
else return False
else return True
#if MIN_VERSION_QuickCheck(2,10,0)
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
functorLaws :: (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws
functorLaws p = Laws "Functor"
[ ("Identity", functorIdentity p)
, ("Composition", functorComposition p)
, ("Const", functorConst p)
]
alternativeLaws :: (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws
alternativeLaws p = Laws "Alternative"
[ ("Identity", alternativeIdentity p)
, ("Associativity", alternativeAssociativity p)
]
applicativeLaws :: (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws
applicativeLaws p = Laws "Applicative"
[ ("Identity", applicativeIdentity p)
, ("Composition", applicativeComposition p)
, ("Homomorphism", applicativeHomomorphism p)
, ("Interchange", applicativeInterchange p)
, ("LiftA2 Part 1", applicativeLiftA2_1 p)
]
altLaws :: (Alt f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws
altLaws p = Laws "Alt"
[ ("Associativity", altAssociative p)
, ("Left Distributivity", altLeftDistributive p)
]
monadLaws :: (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws
monadLaws p = Laws "Monad"
[ ("Left Identity", monadLeftIdentity p)
, ("Right Identity", monadRightIdentity p)
, ("Associativity", monadAssociativity p)
, ("Return", monadReturn p)
, ("Ap", monadAp p)
]
foldableLaws :: (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws
foldableLaws = foldableLawsInternal
foldableLawsInternal :: forall proxy f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws
foldableLawsInternal p = Laws "Foldable"
[ (,) "fold" $ property $ \(Apply (a :: f (SG.Sum Integer))) ->
F.fold a == F.foldMap id a
, (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: Equation) ->
let f = SG.Sum . runEquation e
in F.foldMap f a == F.foldr (mappend . f) mempty a
, (,) "foldr" $ property $ \(e :: EquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->
let f = runEquationTwo e
in F.foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z
, (,) "foldr'" (foldableFoldr' p)
, (,) "foldl" $ property $ \(e :: EquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->
let f = runEquationTwo e
in F.foldl f z t == SG.appEndo (SG.getDual (F.foldMap (SG.Dual . SG.Endo . flip f) t)) z
, (,) "foldl'" (foldableFoldl' p)
, (,) "toList" $ property $ \(Apply (t :: f Integer)) ->
eq1 (F.toList t) (F.foldr (:) [] t)
#if MIN_VERSION_base(4,8,0)
, (,) "null" $ property $ \(Apply (t :: f Integer)) ->
null t == F.foldr (const (const False)) True t
, (,) "length" $ property $ \(Apply (t :: f Integer)) ->
F.length t == SG.getSum (F.foldMap (const (SG.Sum 1)) t)
#endif
]
foldableFoldl' :: forall proxy f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
foldableFoldl' _ = property $ \(_ :: ChooseSecond) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) ->
monadicIO $ do
let f :: Integer -> Bottom Integer -> Integer
f a b = case b of
BottomUndefined -> error "foldableFoldl' example"
BottomValue v -> if even v
then a
else v
z0 = 0
r1 <- lift $ do
let f' x k z = k $! f z x
e <- try (evaluate (F.foldr f' id xs z0))
case e of
Left (_ :: ErrorCall) -> return Nothing
Right i -> return (Just i)
r2 <- lift $ do
e <- try (evaluate (F.foldl' f z0 xs))
case e of
Left (_ :: ErrorCall) -> return Nothing
Right i -> return (Just i)
return (r1 == r2)
foldableFoldr' :: forall proxy f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
foldableFoldr' _ = property $ \(_ :: ChooseFirst) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) ->
monadicIO $ do
let f :: Bottom Integer -> Integer -> Integer
f a b = case a of
BottomUndefined -> error "foldableFoldl' example"
BottomValue v -> if even v
then v
else b
z0 = 0
r1 <- lift $ do
let f' k x z = k $! f x z
e <- try (evaluate (F.foldl f' id xs z0))
case e of
Left (_ :: ErrorCall) -> return Nothing
Right i -> return (Just i)
r2 <- lift $ do
e <- try (evaluate (F.foldr' f z0 xs))
case e of
Left (_ :: ErrorCall) -> return Nothing
Right i -> return (Just i)
return (r1 == r2)
data ChooseSecond = ChooseSecond
deriving (Eq)
data ChooseFirst = ChooseFirst
deriving (Eq)
data LastNothing = LastNothing
deriving (Eq)
data Bottom a = BottomUndefined | BottomValue a
deriving (Eq)
instance Show ChooseFirst where
show ChooseFirst = "\\a b -> if even a then a else b"
instance Show ChooseSecond where
show ChooseSecond = "\\a b -> if even b then a else b"
instance Show LastNothing where
show LastNothing = "0"
instance Show a => Show (Bottom a) where
show x = case x of
BottomUndefined -> "undefined"
BottomValue a -> show a
instance Arbitrary ChooseSecond where
arbitrary = pure ChooseSecond
instance Arbitrary ChooseFirst where
arbitrary = pure ChooseFirst
instance Arbitrary LastNothing where
arbitrary = pure LastNothing
instance Arbitrary a => Arbitrary (Bottom a) where
arbitrary = fmap maybeToBottom arbitrary
shrink x = map maybeToBottom (shrink (bottomToMaybe x))
bottomToMaybe :: Bottom a -> Maybe a
bottomToMaybe BottomUndefined = Nothing
bottomToMaybe (BottomValue a) = Just a
maybeToBottom :: Maybe a -> Bottom a
maybeToBottom Nothing = BottomUndefined
maybeToBottom (Just a) = BottomValue a
newtype Apply f a = Apply { getApply :: f a }
newtype Apply2 f a b = Apply2 { getApply2 :: f a b }
instance (Eq1 f, Eq a) => Eq (Apply f a) where
Apply a == Apply b = eq1 a b
instance (Applicative f, Monoid a) => Semigroup (Apply f a) where
Apply x <> Apply y = Apply $ liftA2 mappend x y
instance (Applicative f, Monoid a) => Monoid (Apply f a) where
mempty = Apply $ pure mempty
mappend = (SG.<>)
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
instance (Eq2 f, Eq a, Eq b) => Eq (Apply2 f a b) where
Apply2 a == Apply2 b = eq2 a b
instance (Show2 f, Show a, Show b) => Show (Apply2 f a b) where
showsPrec p = showsPrec2 p . getApply2
#endif
instance (Arbitrary2 f, Arbitrary a, Arbitrary b) => Arbitrary (Apply2 f a b) where
arbitrary = fmap Apply2 arbitrary2
shrink = fmap Apply2 . shrink2 . getApply2
data LinearEquation = LinearEquation
{ _linearEquationLinear :: Integer
, _linearEquationConstant :: Integer
} deriving (Eq)
instance Show LinearEquation where
showsPrec = showLinear
showList = showLinearList
data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation)
runLinearEquation :: Integer -> LinearEquation -> Integer
runLinearEquation x (LinearEquation a b) = a * x + b
runLinearEquationM :: Functor m => LinearEquationM m -> Integer -> m Integer
runLinearEquationM (LinearEquationM e1 e2) i = if odd i
then fmap (runLinearEquation i) e1
else fmap (runLinearEquation i) e2
instance Eq1 m => Eq (LinearEquationM m) where
LinearEquationM a1 b1 == LinearEquationM a2 b2 = eq1 a1 a2 && eq1 b1 b2
showLinear :: Int -> LinearEquation -> ShowS
showLinear _ (LinearEquation a b) = shows a . showString " * x + " . shows b
showLinearList :: [LinearEquation] -> ShowS
showLinearList xs = SG.appEndo $ mconcat
$ [SG.Endo (showChar '[')]
++ L.intersperse (SG.Endo (showChar ',')) (map (SG.Endo . showLinear 0) xs)
++ [SG.Endo (showChar ']')]
instance Show1 m => Show (LinearEquationM m) where
show (LinearEquationM a b) = (\f -> f "")
$ showString "\\x -> if odd x then "
. showsPrec1 0 a
. showString " else "
. showsPrec1 0 b
instance Arbitrary1 m => Arbitrary (LinearEquationM m) where
arbitrary = liftA2 LinearEquationM arbitrary1 arbitrary1
shrink (LinearEquationM a b) = concat
[ map (\x -> LinearEquationM x b) (shrink1 a)
, map (\x -> LinearEquationM a x) (shrink1 b)
]
instance Arbitrary LinearEquation where
arbitrary = do
(a,b) <- arbitrary
return (LinearEquation (abs a) (abs b))
shrink (LinearEquation a b) =
let xs = shrink (a,b)
in map (\(x,y) -> LinearEquation (abs x) (abs y)) xs
data Equation = Equation Integer Integer Integer
deriving (Eq)
instance Show Equation where
show (Equation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c
instance Arbitrary Equation where
arbitrary = do
(a,b,c) <- arbitrary
return (Equation (abs a) (abs b) (abs c))
shrink (Equation a b c) =
let xs = shrink (a,b,c)
in map (\(x,y,z) -> Equation (abs x) (abs y) (abs z)) xs
runEquation :: Equation -> Integer -> Integer
runEquation (Equation a b c) x = a * x ^ (2 :: Integer) + b * x + c
data EquationTwo = EquationTwo Integer Integer
deriving (Eq)
instance Show EquationTwo where
show (EquationTwo a b) = "\\x y -> " ++ show a ++ " * x + " ++ show b ++ " * y"
instance Arbitrary EquationTwo where
arbitrary = do
(a,b) <- arbitrary
return (EquationTwo (abs a) (abs b))
shrink (EquationTwo a b) =
let xs = shrink (a,b)
in map (\(x,y) -> EquationTwo (abs x) (abs y)) xs
runEquationTwo :: EquationTwo -> Integer -> Integer -> Integer
runEquationTwo (EquationTwo a b) x y = a * x + b * y
instance (Show1 f, Show a) => Show (Apply f a) where
showsPrec p = showsPrec1 p . getApply
instance (Arbitrary1 f, Arbitrary a) => Arbitrary (Apply f a) where
arbitrary = fmap Apply arbitrary1
shrink = map Apply . shrink1 . getApply
functorIdentity :: forall proxy f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
functorIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap id a) a
func1 :: Integer -> (Integer,Integer)
func1 i = (div (i + 5) 3, i * i 2 * i + 1)
func2 :: (Integer,Integer) -> (Bool,Either Ordering Integer)
func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2))
functorComposition :: forall proxy f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
functorComposition _ = property $ \(Apply (a :: f Integer)) ->
eq1 (fmap func2 (fmap func1 a)) (fmap (func2 . func1) a)
functorConst :: forall proxy f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
functorConst _ = property $ \(Apply (a :: f Integer)) ->
eq1 (fmap (const 'X') a) ('X' <$ a)
altAssociative :: forall proxy f. (Alt f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
altAssociative _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 ((a <!> b) <!> c) (a <!> (b <!> c))
altLeftDistributive :: forall proxy f. (Alt f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
altLeftDistributive _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) -> eq1 (id <$> (a <!> b)) ((id <$> a) <!> (id <$> b))
alternativeIdentity :: forall proxy f. (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
alternativeIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 (empty <|> a) a) && (eq1 a (empty <|> a))
alternativeAssociativity :: forall proxy f. (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
alternativeAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (a <|> (b <|> c)) ((a <|> b) <|> c)
applicativeIdentity :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
applicativeIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (pure id <*> a) a
applicativeComposition :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
applicativeComposition _ = property $ \(Apply (u' :: f Equation)) (Apply (v' :: f Equation)) (Apply (w :: f Integer)) ->
let u = fmap runEquation u'
v = fmap runEquation v'
in eq1 (pure (.) <*> u <*> v <*> w) (u <*> (v <*> w))
applicativeHomomorphism :: forall proxy f. (Applicative f, Eq1 f, Show1 f) => proxy f -> Property
applicativeHomomorphism _ = property $ \(e :: Equation) (a :: Integer) ->
let f = runEquation e
in eq1 (pure f <*> pure a) (pure (f a) :: f Integer)
applicativeInterchange :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
applicativeInterchange _ = property $ \(Apply (u' :: f Equation)) (y :: Integer) ->
let u = fmap runEquation u'
in eq1 (u <*> pure y) (pure ($ y) <*> u)
applicativeLiftA2_1 :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
applicativeLiftA2_1 _ = property $ \(Apply (f' :: f Equation)) (Apply (x :: f Integer)) ->
let f = fmap runEquation f'
in eq1 (liftA2 id f x) (f <*> x)
monadLeftIdentity :: forall proxy f. (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
monadLeftIdentity _ = property $ \(k' :: LinearEquationM f) (a :: Integer) ->
let k = runLinearEquationM k'
in eq1 (return a >>= k) (k a)
monadRightIdentity :: forall proxy f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
monadRightIdentity _ = property $ \(Apply (m :: f Integer)) ->
eq1 (m >>= return) m
monadAssociativity :: forall proxy f. (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
monadAssociativity _ = property $ \(Apply (m :: f Integer)) (k' :: LinearEquationM f) (h' :: LinearEquationM f) ->
let k = runLinearEquationM k'
h = runLinearEquationM h'
in eq1 (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h)
monadReturn :: forall proxy f. (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
monadReturn _ = property $ \(x :: Integer) ->
eq1 (return x) (pure x :: f Integer)
monadAp :: forall proxy f. (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property
monadAp _ = property $ \(Apply (f' :: f Equation)) (Apply (x :: f Integer)) ->
let f = fmap runEquation f'
in eq1 (ap f x) (f <*> x)
#endif
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
bifunctorLaws :: (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Laws
bifunctorLaws p = Laws "Bifunctor"
[ ("Identity", bifunctorIdentity p)
, ("First Identity", bifunctorFirstIdentity p)
, ("Second Identity", bifunctorSecondIdentity p)
, ("Bifunctor Composition", bifunctorComposition p)
]
bifunctorIdentity :: forall proxy f. (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Property
bifunctorIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (bimap id id x) x
bifunctorFirstIdentity :: forall proxy f. (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Property
bifunctorFirstIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (first id x) x
bifunctorSecondIdentity :: forall proxy f. (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Property
bifunctorSecondIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (second id x) x
bifunctorComposition
:: forall proxy f.
(Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)
=> proxy f -> Property
bifunctorComposition _ = property $ \(Apply2 (z :: f Integer Integer)) -> eq2 (bimap id id z) ((first id . second id) z)
#endif
#endif
myForAllShrink :: (Arbitrary a, Show b, Eq b) => Bool -> (a -> Bool) -> (a -> [String]) -> String -> (a -> b) -> String -> (a -> b) -> Property
myForAllShrink displayRhs isValid showInputs name1 calc1 name2 calc2 =
again $
MkProperty $
arbitrary >>= \x ->
unProperty $
shrinking shrink x $ \x' ->
let b1 = calc1 x'
b2 = calc2 x'
sb1 = show b1
sb2 = show b2
description = " Description: " ++ name1 ++ " = " ++ name2
err = description ++ "\n" ++ unlines (map (" " ++) (showInputs x')) ++ " " ++ name1 ++ " = " ++ sb1 ++ (if displayRhs then "\n " ++ name2 ++ " = " ++ sb2 else "")
in isValid x' ==> counterexample err (b1 == b2)
#if MIN_VERSION_base(4,7,0)
newtype BitIndex a = BitIndex Int
instance FiniteBits a => Arbitrary (BitIndex a) where
arbitrary = let n = finiteBitSize (undefined :: a) in if n > 0
then fmap BitIndex (choose (0,n 1))
else return (BitIndex 0)
shrink (BitIndex x) = if x > 0 then map BitIndex (S.toList (S.fromList [x 1, div x 2, 0])) else []
#endif
data PrimArray a = PrimArray ByteArray#
data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s)
instance (Eq a, Prim a) => Eq (PrimArray a) where
a1 == a2 = sizeofPrimArray a1 == sizeofPrimArray a2 && loop (sizeofPrimArray a1 1)
where
loop !i | i < 0 = True
| otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i1)
#if MIN_VERSION_base(4,7,0)
instance Prim a => IsList (PrimArray a) where
type Item (PrimArray a) = a
fromList = primArrayFromList
fromListN = primArrayFromListN
toList = primArrayToList
#endif
indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i#
sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int
sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a)))
newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (I# n#)
= primitive (\s# ->
case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of
(# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)
)
readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray (MutablePrimArray arr#) (I# i#)
= primitive (readByteArray# arr# i#)
writePrimArray ::
(Prim a, PrimMonad m)
=> MutablePrimArray (PrimState m) a
-> Int
-> a
-> m ()
writePrimArray (MutablePrimArray arr#) (I# i#) x
= primitive_ (writeByteArray# arr# i# x)
unsafeFreezePrimArray
:: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray (MutablePrimArray arr#)
= primitive (\s# -> case unsafeFreezeByteArray# arr# s# of
(# s'#, arr'# #) -> (# s'#, PrimArray arr'# #))
copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)
=> Ptr a
-> PrimArray a
-> Int
-> Int
-> m ()
copyPrimArrayToPtr addr@(Ptr addr#) ba@(PrimArray ba#) soff@(I# soff#) n@(I# n#) =
#if MIN_VERSION_base(4,7,0)
primitive (\ s# ->
let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s#
in (# s'#, () #))
where siz# = sizeOf# (undefined :: a)
#else
generateM_ n $ \ix -> writeOffAddr (ptrToAddr addr) ix (indexPrimArray ba (ix + soff))
#endif
ptrToAddr :: Ptr a -> Addr
ptrToAddr (Ptr x) = Addr x
generateM_ :: Monad m => Int -> (Int -> m a) -> m ()
generateM_ n f = go 0 where
go !ix = if ix < n
then f ix >> go (ix + 1)
else return ()
copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a)
=> MutablePrimArray (PrimState m) a
-> Int
-> Ptr a
-> Int
-> m ()
copyPtrToMutablePrimArray ba@(MutablePrimArray ba#) doff@(I# doff#) addr@(Ptr addr#) n@(I# n#) =
#if MIN_VERSION_base(4,7,0)
primitive (\ s# ->
let s'# = copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#) s#
in (# s'#, () #))
where siz# = sizeOf# (undefined :: a)
#else
generateM_ n $ \ix -> do
x <- readOffAddr (ptrToAddr addr) ix
writePrimArray ba (doff + ix) x
#endif
copyMutablePrimArray :: forall m a.
(PrimMonad m, Prim a)
=> MutablePrimArray (PrimState m) a
-> Int
-> MutablePrimArray (PrimState m) a
-> Int
-> Int
-> m ()
copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#)
= primitive_ (copyMutableByteArray#
src#
(soff# *# (sizeOf# (undefined :: a)))
dst#
(doff# *# (sizeOf# (undefined :: a)))
(n# *# (sizeOf# (undefined :: a)))
)
copyPrimArray :: forall m a.
(PrimMonad m, Prim a)
=> MutablePrimArray (PrimState m) a
-> Int
-> PrimArray a
-> Int
-> Int
-> m ()
copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#)
= primitive_ (copyByteArray#
src#
(soff# *# (sizeOf# (undefined :: a)))
dst#
(doff# *# (sizeOf# (undefined :: a)))
(n# *# (sizeOf# (undefined :: a)))
)
primArrayFromList :: Prim a => [a] -> PrimArray a
primArrayFromList xs = primArrayFromListN (L.length xs) xs
primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a
primArrayFromListN len vs = runST run where
run :: forall s. ST s (PrimArray a)
run = do
arr <- newPrimArray len
let go :: [a] -> Int -> ST s ()
go !xs !ix = case xs of
[] -> return ()
a : as -> do
writePrimArray arr ix a
go as (ix + 1)
go vs 0
unsafeFreezePrimArray arr
primArrayToList :: forall a. Prim a => PrimArray a -> [a]
primArrayToList arr = go 0 where
!len = sizeofPrimArray arr
go :: Int -> [a]
go !ix = if ix < len
then indexPrimArray arr ix : go (ix + 1)
else []