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, 0 insertions, 342 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 deleted file mode 100644 index abec96df032d..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/test/main.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# 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) - - - |