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 Control.Monad.Fix (mfix) 10import Data.Int 11import Data.Word 12import Data.Typeable 13import qualified Data.List as List 14import qualified Data.Vector.Generic as Generic 15import qualified Data.Vector as Boxed 16import qualified Data.Vector.Mutable as MBoxed 17import qualified Data.Vector.Primitive as Primitive 18import qualified Data.Vector.Storable as Storable 19import qualified Data.Vector.Unboxed as Unboxed 20import Foreign.Ptr 21import Foreign.Storable 22import Text.Printf 23 24import Test.Tasty 25import Test.Tasty.HUnit (testCase, Assertion, assertBool, assertEqual, (@=?), assertFailure) 26 27 28newtype Aligned a = Aligned { getAligned :: a } 29 30instance (Storable a) => Storable (Aligned a) where 31 sizeOf _ = sizeOf (undefined :: a) 32 alignment _ = 128 33 peek ptr = Aligned Applicative.<$> peek (castPtr ptr) 34 poke ptr = poke (castPtr ptr) . getAligned 35 36checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion 37checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do 38 let ptr' = ptrToWordPtr ptr 39 msg = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr') 40 align :: WordPtr 41 align = fromIntegral $ alignment dummy 42 assertBool msg $ (ptr' `mod` align) == 0 43 where 44 dummy :: a 45 dummy = undefined 46 47tests :: [TestTree] 48tests = 49 [ testGroup "Data.Vector.Storable.Vector Alignment" 50 [ testCase "Aligned Double" $ 51 checkAddressAlignment alignedDoubleVec 52 , testCase "Aligned Int" $ 53 checkAddressAlignment alignedIntVec 54 ] 55 , testGroup "Regression tests" 56 [ testGroup "enumFromTo crash #188" 57 [ regression188 ([] :: [Word8]) 58 , regression188 ([] :: [Word16]) 59 , regression188 ([] :: [Word32]) 60 , regression188 ([] :: [Word64]) 61 , regression188 ([] :: [Word]) 62 , regression188 ([] :: [Int8]) 63 , regression188 ([] :: [Int16]) 64 , regression188 ([] :: [Int32]) 65 , regression188 ([] :: [Int64]) 66 , regression188 ([] :: [Int]) 67 , regression188 ([] :: [Char]) 68 ] 69 ] 70 , testGroup "Negative tests" 71 [ testGroup "slice out of bounds #257" 72 [ testGroup "Boxed" $ testsSliceOutOfBounds Boxed.slice 73 , testGroup "Primitive" $ testsSliceOutOfBounds Primitive.slice 74 , testGroup "Storable" $ testsSliceOutOfBounds Storable.slice 75 , testGroup "Unboxed" $ testsSliceOutOfBounds Unboxed.slice 76 ] 77 , testGroup "take #282" 78 [ testCase "Boxed" $ testTakeOutOfMemory Boxed.take 79 , testCase "Primitive" $ testTakeOutOfMemory Primitive.take 80 , testCase "Storable" $ testTakeOutOfMemory Storable.take 81 , testCase "Unboxed" $ testTakeOutOfMemory Unboxed.take 82 ] 83 ] 84 , testGroup "Data.Vector" 85 [ testCase "MonadFix" checkMonadFix 86 , testCase "toFromArray" toFromArray 87 , testCase "toFromMutableArray" toFromMutableArray 88 ] 89 ] 90 91testsSliceOutOfBounds :: 92 (Show (v Int), Generic.Vector v Int) => (Int -> Int -> v Int -> v Int) -> [TestTree] 93testsSliceOutOfBounds sliceWith = 94 [ testCase "Negative ix" $ sliceTest sliceWith (-2) 2 xs 95 , testCase "Negative size" $ sliceTest sliceWith 2 (-2) xs 96 , testCase "Negative ix and size" $ sliceTest sliceWith (-2) (-1) xs 97 , testCase "Too large ix" $ sliceTest sliceWith 6 2 xs 98 , testCase "Too large size" $ sliceTest sliceWith 2 6 xs 99 , testCase "Too large ix and size" $ sliceTest sliceWith 6 6 xs 100 , testCase "Overflow" $ sliceTest sliceWith 1 maxBound xs 101 , testCase "OutOfMemory" $ sliceTest sliceWith 1 (maxBound `div` intSize) xs 102 ] 103 where 104 intSize = sizeOf (undefined :: Int) 105 xs = [1, 2, 3, 4, 5] :: [Int] 106{-# INLINE testsSliceOutOfBounds #-} 107 108sliceTest :: 109 (Show (v Int), Generic.Vector v Int) 110 => (Int -> Int -> v Int -> v Int) 111 -> Int 112 -> Int 113 -> [Int] 114 -> Assertion 115sliceTest sliceWith i m xs = do 116 let vec = Generic.fromList xs 117 eRes <- try (pure $! sliceWith i m vec) 118 case eRes of 119 Right v -> 120 assertFailure $ 121 "Data.Vector.Internal.Check.checkSlice failed to check: " ++ show v 122 Left (ErrorCall err) -> 123 let assertMsg = 124 List.concat 125 [ "Expected slice function to produce an 'error' ending with: \"" 126 , errSuffix 127 , "\" instead got: \"" 128 , err 129 ] 130 in assertBool assertMsg (errSuffix `List.isSuffixOf` err) 131 where 132 errSuffix = 133 "(slice): invalid slice (" ++ 134 show i ++ "," ++ show m ++ "," ++ show (List.length xs) ++ ")" 135{-# INLINE sliceTest #-} 136 137testTakeOutOfMemory :: 138 (Show (v Int), Eq (v Int), Generic.Vector v Int) => (Int -> v Int -> v Int) -> Assertion 139testTakeOutOfMemory takeWith = 140 takeWith (maxBound `div` intSize) (Generic.fromList xs) @=? Generic.fromList xs 141 where 142 intSize = sizeOf (undefined :: Int) 143 xs = [1, 2, 3, 4, 5] :: [Int] 144{-# INLINE testTakeOutOfMemory #-} 145 146regression188 147 :: forall proxy a. (Typeable a, Enum a, Bounded a, Eq a, Show a) 148 => proxy a -> TestTree 149regression188 _ = testCase (show (typeOf (undefined :: a))) 150 $ Boxed.fromList [maxBound::a] @=? Boxed.enumFromTo maxBound maxBound 151{-# INLINE regression188 #-} 152 153alignedDoubleVec :: Storable.Vector (Aligned Double) 154alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] 155 156alignedIntVec :: Storable.Vector (Aligned Int) 157alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] 158 159#if __GLASGOW_HASKELL__ >= 800 160-- Ensure that Mutable is really an injective type family by typechecking a 161-- function which relies on injectivity. 162_f :: (Generic.Vector v a, Generic.Vector w a, PrimMonad f) 163 => Generic.Mutable v (PrimState f) a -> f (w a) 164_f v = Generic.convert `fmap` Generic.unsafeFreeze v 165#endif 166 167checkMonadFix :: Assertion 168checkMonadFix = assertBool "checkMonadFix" $ 169 Boxed.toList fewV == fewL && 170 Boxed.toList none == [] 171 where 172 facty _ 0 = 1; facty f n = n * f (n - 1) 173 fewV :: Boxed.Vector Int 174 fewV = fmap ($ 12) $ mfix (\i -> Boxed.fromList [facty i, facty (+1), facty (+2)]) 175 fewL :: [Int] 176 fewL = fmap ($ 12) $ mfix (\i -> [facty i, facty (+1), facty (+2)]) 177 none :: Boxed.Vector Int 178 none = mfix (const Boxed.empty) 179 180mkArrayRoundtrip :: (String -> Boxed.Vector Integer -> Assertion) -> Assertion 181mkArrayRoundtrip mkAssertion = 182 sequence_ 183 [ mkAssertion name v 184 | (name, v) <- 185 [ ("full", vec) 186 , ("slicedTail", Boxed.slice 0 (n - 3) vec) 187 , ("slicedHead", Boxed.slice 2 (n - 2) vec) 188 , ("slicedBoth", Boxed.slice 2 (n - 4) vec) 189 ] 190 ] 191 where 192 vec = Boxed.fromList [0 .. 10] 193 n = Boxed.length vec 194 195toFromArray :: Assertion 196toFromArray = 197 mkArrayRoundtrip $ \name v -> 198 assertEqual name v $ Boxed.fromArray (Boxed.toArray v) 199 200toFromMutableArray :: Assertion 201toFromMutableArray = mkArrayRoundtrip assetRoundtrip 202 where 203 assetRoundtrip assertionName vec = do 204 mvec <- Boxed.unsafeThaw vec 205 mvec' <- MBoxed.fromMutableArray =<< MBoxed.toMutableArray mvec 206 vec' <- Boxed.unsafeFreeze mvec' 207 assertEqual assertionName vec vec' 208