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