1{-# LANGUAGE CPP #-} 2{-# LANGUAGE ScopedTypeVariables #-} 3 4module Tests.Vector.UnitTests (tests) where 5 6import Control.Applicative as Applicative 7import Control.Exception 8import Control.Monad.Primitive 9import Data.Int 10import Data.Word 11import Data.Typeable 12import qualified Data.List as List 13import qualified Data.Vector.Generic as Generic 14import qualified Data.Vector as Boxed 15import qualified Data.Vector.Primitive as Primitive 16import qualified Data.Vector.Storable as Storable 17import qualified Data.Vector.Unboxed as Unboxed 18import qualified Data.Vector as Vector 19import Foreign.Ptr 20import Foreign.Storable 21import Text.Printf 22 23import Test.Tasty 24import Test.Tasty.HUnit (testCase,Assertion, assertBool, (@=?), assertFailure) 25-- import Test.HUnit () 26 27newtype Aligned a = Aligned { getAligned :: a } 28 29instance (Storable a) => Storable (Aligned a) where 30 sizeOf _ = sizeOf (undefined :: a) 31 alignment _ = 128 32 peek ptr = Aligned Applicative.<$> peek (castPtr ptr) 33 poke ptr = poke (castPtr ptr) . getAligned 34 35checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion 36checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do 37 let ptr' = ptrToWordPtr ptr 38 msg = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr') 39 align :: WordPtr 40 align = fromIntegral $ alignment dummy 41 assertBool msg $ (ptr' `mod` align) == 0 42 where 43 dummy :: a 44 dummy = undefined 45 46tests :: [TestTree] 47tests = 48 [ testGroup "Data.Vector.Storable.Vector Alignment" 49 [ testCase "Aligned Double" $ 50 checkAddressAlignment alignedDoubleVec 51 , testCase "Aligned Int" $ 52 checkAddressAlignment alignedIntVec 53 ] 54 , testGroup "Regression tests" 55 [ testGroup "enumFromTo crash #188" 56 [ regression188 ([] :: [Word8]) 57 , regression188 ([] :: [Word16]) 58 , regression188 ([] :: [Word32]) 59 , regression188 ([] :: [Word64]) 60 , regression188 ([] :: [Word]) 61 , regression188 ([] :: [Int8]) 62 , regression188 ([] :: [Int16]) 63 , regression188 ([] :: [Int32]) 64 , regression188 ([] :: [Int64]) 65 , regression188 ([] :: [Int]) 66 , regression188 ([] :: [Char]) 67 ] 68 ] 69 , testGroup "Negative tests" 70 [ testGroup "slice out of bounds #257" 71 [ testGroup "Boxed" $ testsSliceOutOfBounds Boxed.slice 72 , testGroup "Primitive" $ testsSliceOutOfBounds Primitive.slice 73 , testGroup "Storable" $ testsSliceOutOfBounds Storable.slice 74 , testGroup "Unboxed" $ testsSliceOutOfBounds Unboxed.slice 75 ] 76 , testGroup "take #282" 77 [ testCase "Boxed" $ testTakeOutOfMemory Boxed.take 78 , testCase "Primitive" $ testTakeOutOfMemory Primitive.take 79 , testCase "Storable" $ testTakeOutOfMemory Storable.take 80 , testCase "Unboxed" $ testTakeOutOfMemory Unboxed.take 81 ] 82 ] 83 ] 84 85testsSliceOutOfBounds :: 86 (Show (v Int), Generic.Vector v Int) => (Int -> Int -> v Int -> v Int) -> [TestTree] 87testsSliceOutOfBounds sliceWith = 88 [ testCase "Negative ix" $ sliceTest sliceWith (-2) 2 xs 89 , testCase "Negative size" $ sliceTest sliceWith 2 (-2) xs 90 , testCase "Negative ix and size" $ sliceTest sliceWith (-2) (-1) xs 91 , testCase "Too large ix" $ sliceTest sliceWith 6 2 xs 92 , testCase "Too large size" $ sliceTest sliceWith 2 6 xs 93 , testCase "Too large ix and size" $ sliceTest sliceWith 6 6 xs 94 , testCase "Overflow" $ sliceTest sliceWith 1 maxBound xs 95 , testCase "OutOfMemory" $ sliceTest sliceWith 1 (maxBound `div` intSize) xs 96 ] 97 where 98 intSize = sizeOf (undefined :: Int) 99 xs = [1, 2, 3, 4, 5] :: [Int] 100{-# INLINE testsSliceOutOfBounds #-} 101 102sliceTest :: 103 (Show (v Int), Generic.Vector v Int) 104 => (Int -> Int -> v Int -> v Int) 105 -> Int 106 -> Int 107 -> [Int] 108 -> Assertion 109sliceTest sliceWith i m xs = do 110 let vec = Generic.fromList xs 111 eRes <- try (pure $! sliceWith i m vec) 112 case eRes of 113 Right v -> 114 assertFailure $ 115 "Data.Vector.Internal.Check.checkSlice failed to check: " ++ show v 116 Left (ErrorCall err) -> 117 let assertMsg = 118 List.concat 119 [ "Expected slice function to produce an 'error' ending with: \"" 120 , errSuffix 121 , "\" instead got: \"" 122 , err 123 ] 124 in assertBool assertMsg (errSuffix `List.isSuffixOf` err) 125 where 126 errSuffix = 127 "(slice): invalid slice (" ++ 128 show i ++ "," ++ show m ++ "," ++ show (List.length xs) ++ ")" 129{-# INLINE sliceTest #-} 130 131testTakeOutOfMemory :: 132 (Show (v Int), Eq (v Int), Generic.Vector v Int) => (Int -> v Int -> v Int) -> Assertion 133testTakeOutOfMemory takeWith = 134 takeWith (maxBound `div` intSize) (Generic.fromList xs) @=? Generic.fromList xs 135 where 136 intSize = sizeOf (undefined :: Int) 137 xs = [1, 2, 3, 4, 5] :: [Int] 138{-# INLINE testTakeOutOfMemory #-} 139 140regression188 141 :: forall proxy a. (Typeable a, Enum a, Bounded a, Eq a, Show a) 142 => proxy a -> TestTree 143regression188 _ = testCase (show (typeOf (undefined :: a))) 144 $ Vector.fromList [maxBound::a] @=? Vector.enumFromTo maxBound maxBound 145{-# INLINE regression188 #-} 146 147alignedDoubleVec :: Storable.Vector (Aligned Double) 148alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] 149 150alignedIntVec :: Storable.Vector (Aligned Int) 151alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] 152 153#if __GLASGOW_HASKELL__ >= 800 154-- Ensure that Mutable is really an injective type family by typechecking a 155-- function which relies on injectivity. 156_f :: (Generic.Vector v a, Generic.Vector w a, PrimMonad f) 157 => Generic.Mutable v (PrimState f) a -> f (w a) 158_f v = Generic.convert `fmap` Generic.unsafeFreeze v 159#endif 160