diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/primitive/test/main.hs')
| -rw-r--r-- | third_party/bazel/rules_haskell/examples/primitive/test/main.hs | 342 |
1 files changed, 342 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/main.hs b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs new file mode 100644 index 0000000000..abec96df03 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs @@ -0,0 +1,342 @@ +{-# 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) + + + |