342 lines
14 KiB
Haskell
342 lines
14 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE MagicHash #-}
|
|
{-# LANGUAGE UnboxedTuples #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Control.Monad.Fix (fix)
|
|
import Control.Monad.Primitive
|
|
import Control.Monad.ST
|
|
import Data.Monoid
|
|
import Data.Primitive
|
|
import Data.Primitive.Array
|
|
import Data.Primitive.ByteArray
|
|
import Data.Primitive.Types
|
|
import Data.Primitive.SmallArray
|
|
import Data.Primitive.PrimArray
|
|
import Data.Word
|
|
import Data.Proxy (Proxy(..))
|
|
import GHC.Int
|
|
import GHC.IO
|
|
import GHC.Prim
|
|
import Data.Function (on)
|
|
#if MIN_VERSION_base(4,9,0)
|
|
import Data.Semigroup (stimes)
|
|
#endif
|
|
|
|
import Test.Tasty (defaultMain,testGroup,TestTree)
|
|
import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function)
|
|
import qualified Test.Tasty.QuickCheck as TQC
|
|
import qualified Test.QuickCheck as QC
|
|
import qualified Test.QuickCheck.Classes as QCC
|
|
import qualified Test.QuickCheck.Classes.IsList as QCCL
|
|
import qualified Data.List as L
|
|
|
|
main :: IO ()
|
|
main = do
|
|
testArray
|
|
testByteArray
|
|
defaultMain $ testGroup "properties"
|
|
[ testGroup "Array"
|
|
[ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int)))
|
|
, lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int)))
|
|
, lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int)))
|
|
, lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))
|
|
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
|
|
, lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array))
|
|
, lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array))
|
|
, lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array))
|
|
, lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array))
|
|
, lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array))
|
|
#endif
|
|
#if MIN_VERSION_base(4,7,0)
|
|
, lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int)))
|
|
, TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')
|
|
#endif
|
|
]
|
|
, testGroup "SmallArray"
|
|
[ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int)))
|
|
, lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int)))
|
|
, lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int)))
|
|
, lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))
|
|
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
|
|
, lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray))
|
|
, lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray))
|
|
, lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray))
|
|
, lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray))
|
|
, lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray))
|
|
#endif
|
|
#if MIN_VERSION_base(4,7,0)
|
|
, lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int)))
|
|
, TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')
|
|
#endif
|
|
]
|
|
, testGroup "ByteArray"
|
|
[ testGroup "Ordering"
|
|
[ TQC.testProperty "equality" byteArrayEqProp
|
|
, TQC.testProperty "compare" byteArrayCompareProp
|
|
]
|
|
, testGroup "Resize"
|
|
[ TQC.testProperty "shrink" byteArrayShrinkProp
|
|
, TQC.testProperty "grow" byteArrayGrowProp
|
|
]
|
|
, lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray))
|
|
, lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray))
|
|
, lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))
|
|
#if MIN_VERSION_base(4,7,0)
|
|
, lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))
|
|
#endif
|
|
]
|
|
, testGroup "PrimArray"
|
|
[ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16)))
|
|
, lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16)))
|
|
, lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))
|
|
#if MIN_VERSION_base(4,7,0)
|
|
, lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16)))
|
|
, TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray)
|
|
, TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray')
|
|
, TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray)
|
|
, TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray')
|
|
, TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM')
|
|
, TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray)
|
|
, TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray)
|
|
, TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP)
|
|
, TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray)
|
|
, TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray)
|
|
, TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP)
|
|
, TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray)
|
|
, TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA)
|
|
, TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP)
|
|
, TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray)
|
|
, TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA)
|
|
, TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP)
|
|
, TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray)
|
|
, TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA)
|
|
, TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP)
|
|
, TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray)
|
|
, TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA)
|
|
, TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP)
|
|
#endif
|
|
]
|
|
, testGroup "UnliftedArray"
|
|
[ lawsToTest (QCC.eqLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
|
|
, lawsToTest (QCC.ordLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
|
|
, lawsToTest (QCC.monoidLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
|
|
#if MIN_VERSION_base(4,7,0)
|
|
, lawsToTest (QCC.isListLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
|
|
, TQC.testProperty "mapUnliftedArray" (QCCL.mapProp arrInt16 arrInt32 mapUnliftedArray)
|
|
, TQC.testProperty "foldrUnliftedArray" (QCCL.foldrProp arrInt16 foldrUnliftedArray)
|
|
, TQC.testProperty "foldrUnliftedArray'" (QCCL.foldrProp arrInt16 foldrUnliftedArray')
|
|
, TQC.testProperty "foldlUnliftedArray" (QCCL.foldlProp arrInt16 foldlUnliftedArray)
|
|
, TQC.testProperty "foldlUnliftedArray'" (QCCL.foldlProp arrInt16 foldlUnliftedArray')
|
|
#endif
|
|
]
|
|
, testGroup "DefaultSetMethod"
|
|
[ lawsToTest (QCC.primLaws (Proxy :: Proxy DefaultSetMethod))
|
|
]
|
|
-- , testGroup "PrimStorable"
|
|
-- [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived))
|
|
-- ]
|
|
]
|
|
|
|
int16 :: Proxy Int16
|
|
int16 = Proxy
|
|
|
|
int32 :: Proxy Int32
|
|
int32 = Proxy
|
|
|
|
arrInt16 :: Proxy (PrimArray Int16)
|
|
arrInt16 = Proxy
|
|
|
|
arrInt32 :: Proxy (PrimArray Int16)
|
|
arrInt32 = Proxy
|
|
|
|
-- Tests that using resizeByteArray to shrink a byte array produces
|
|
-- the same results as calling Data.List.take on the list that the
|
|
-- byte array corresponds to.
|
|
byteArrayShrinkProp :: QC.Property
|
|
byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->
|
|
let large = max n m
|
|
small = min n m
|
|
xs = intsLessThan large
|
|
ys = byteArrayFromList xs
|
|
largeBytes = large * sizeOf (undefined :: Int)
|
|
smallBytes = small * sizeOf (undefined :: Int)
|
|
expected = byteArrayFromList (L.take small xs)
|
|
actual = runST $ do
|
|
mzs0 <- newByteArray largeBytes
|
|
copyByteArray mzs0 0 ys 0 largeBytes
|
|
mzs1 <- resizeMutableByteArray mzs0 smallBytes
|
|
unsafeFreezeByteArray mzs1
|
|
in expected === actual
|
|
|
|
-- Tests that using resizeByteArray with copyByteArray (to fill in the
|
|
-- new empty space) to grow a byte array produces the same results as
|
|
-- calling Data.List.++ on the lists corresponding to the original
|
|
-- byte array and the appended byte array.
|
|
byteArrayGrowProp :: QC.Property
|
|
byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->
|
|
let large = max n m
|
|
small = min n m
|
|
xs1 = intsLessThan small
|
|
xs2 = intsLessThan (large - small)
|
|
ys1 = byteArrayFromList xs1
|
|
ys2 = byteArrayFromList xs2
|
|
largeBytes = large * sizeOf (undefined :: Int)
|
|
smallBytes = small * sizeOf (undefined :: Int)
|
|
expected = byteArrayFromList (xs1 ++ xs2)
|
|
actual = runST $ do
|
|
mzs0 <- newByteArray smallBytes
|
|
copyByteArray mzs0 0 ys1 0 smallBytes
|
|
mzs1 <- resizeMutableByteArray mzs0 largeBytes
|
|
copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int))
|
|
unsafeFreezeByteArray mzs1
|
|
in expected === actual
|
|
|
|
-- Provide the non-negative integers up to the bound. For example:
|
|
--
|
|
-- >>> intsLessThan 5
|
|
-- [0,1,2,3,4]
|
|
intsLessThan :: Int -> [Int]
|
|
intsLessThan i = if i < 1
|
|
then []
|
|
else (i - 1) : intsLessThan (i - 1)
|
|
|
|
byteArrayCompareProp :: QC.Property
|
|
byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->
|
|
compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys)
|
|
|
|
byteArrayEqProp :: QC.Property
|
|
byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->
|
|
(compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys)
|
|
|
|
compareLengthFirst :: [Word8] -> [Word8] -> Ordering
|
|
compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys
|
|
|
|
-- on GHC 7.4, Proxy is not polykinded, so we need this instead.
|
|
data Proxy1 (f :: * -> *) = Proxy1
|
|
|
|
lawsToTest :: QCC.Laws -> TestTree
|
|
lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)
|
|
|
|
testArray :: IO ()
|
|
testArray = do
|
|
arr <- newArray 1 'A'
|
|
let unit =
|
|
case writeArray arr 0 'B' of
|
|
IO f ->
|
|
case f realWorld# of
|
|
(# _, _ #) -> ()
|
|
c1 <- readArray arr 0
|
|
return $! unit
|
|
c2 <- readArray arr 0
|
|
if c1 == 'A' && c2 == 'B'
|
|
then return ()
|
|
else error $ "Expected AB, got: " ++ show (c1, c2)
|
|
|
|
testByteArray :: IO ()
|
|
testByteArray = do
|
|
let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])
|
|
arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])
|
|
arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8])
|
|
arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8])
|
|
arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8])
|
|
when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $
|
|
fail $ "ByteArray Show incorrect: "++show arr1
|
|
unless (arr1 > arr3) $
|
|
fail $ "ByteArray Ord incorrect"
|
|
unless (arr1 == arr2) $
|
|
fail $ "ByteArray Eq incorrect"
|
|
unless (mappend arr1 arr4 == arr5) $
|
|
fail $ "ByteArray Monoid mappend incorrect"
|
|
unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $
|
|
fail $ "ByteArray Monoid mappend not associative"
|
|
unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $
|
|
fail $ "ByteArray Monoid mconcat incorrect"
|
|
#if MIN_VERSION_base(4,9,0)
|
|
unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $
|
|
fail $ "ByteArray Semigroup stimes incorrect"
|
|
#endif
|
|
|
|
mkByteArray :: Prim a => [a] -> ByteArray
|
|
mkByteArray xs = runST $ do
|
|
marr <- newByteArray (length xs * sizeOf (head xs))
|
|
sequence $ zipWith (writeByteArray marr) [0..] xs
|
|
unsafeFreezeByteArray marr
|
|
|
|
instance Arbitrary1 Array where
|
|
liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen)
|
|
|
|
instance Arbitrary a => Arbitrary (Array a) where
|
|
arbitrary = fmap fromList QC.arbitrary
|
|
|
|
instance Arbitrary1 SmallArray where
|
|
liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen)
|
|
|
|
instance Arbitrary a => Arbitrary (SmallArray a) where
|
|
arbitrary = fmap smallArrayFromList QC.arbitrary
|
|
|
|
instance Arbitrary ByteArray where
|
|
arbitrary = do
|
|
xs <- QC.arbitrary :: Gen [Word8]
|
|
return $ runST $ do
|
|
a <- newByteArray (L.length xs)
|
|
iforM_ xs $ \ix x -> do
|
|
writeByteArray a ix x
|
|
unsafeFreezeByteArray a
|
|
|
|
instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where
|
|
arbitrary = do
|
|
xs <- QC.arbitrary :: Gen [a]
|
|
return $ runST $ do
|
|
a <- newPrimArray (L.length xs)
|
|
iforM_ xs $ \ix x -> do
|
|
writePrimArray a ix x
|
|
unsafeFreezePrimArray a
|
|
|
|
instance (Arbitrary a, PrimUnlifted a) => Arbitrary (UnliftedArray a) where
|
|
arbitrary = do
|
|
xs <- QC.vector =<< QC.choose (0,3)
|
|
return (unliftedArrayFromList xs)
|
|
|
|
instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where
|
|
coarbitrary x = QC.coarbitrary (primArrayToList x)
|
|
|
|
instance (Prim a, Function a) => Function (PrimArray a) where
|
|
function = QC.functionMap primArrayToList primArrayFromList
|
|
|
|
iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m ()
|
|
iforM_ xs0 f = go 0 xs0 where
|
|
go !_ [] = return ()
|
|
go !ix (x : xs) = f ix x >> go (ix + 1) xs
|
|
|
|
newtype DefaultSetMethod = DefaultSetMethod Int16
|
|
deriving (Eq,Show,Arbitrary)
|
|
|
|
instance Prim DefaultSetMethod where
|
|
sizeOf# _ = sizeOf# (undefined :: Int16)
|
|
alignment# _ = alignment# (undefined :: Int16)
|
|
indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix)
|
|
readByteArray# arr ix s0 = case readByteArray# arr ix s0 of
|
|
(# s1, n #) -> (# s1, DefaultSetMethod n #)
|
|
writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0
|
|
setByteArray# = defaultSetByteArray#
|
|
indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off)
|
|
readOffAddr# addr off s0 = case readOffAddr# addr off s0 of
|
|
(# s1, n #) -> (# s1, DefaultSetMethod n #)
|
|
writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0
|
|
setOffAddr# = defaultSetOffAddr#
|
|
|
|
-- TODO: Uncomment this out when GHC 8.6 is release. Also, uncomment
|
|
-- the corresponding PrimStorable test group above.
|
|
--
|
|
-- newtype Derived = Derived Int16
|
|
-- deriving newtype (Prim)
|
|
-- deriving Storable via (PrimStorable Derived)
|
|
|
|
|
|
|