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