UnitTests.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Tests.Vector.UnitTests (tests) where

import Control.Applicative as Applicative
import Control.Exception
import Control.Monad.Primitive
import Control.Monad.Fix (mfix)
import Data.Int
import Data.Word
import Data.Typeable
import qualified Data.List as List
import qualified Data.Vector.Generic  as Generic
import qualified Data.Vector as Boxed
import qualified Data.Vector.Internal.Check as Check
import qualified Data.Vector.Mutable as MBoxed
import qualified Data.Vector.Primitive as Primitive
import qualified Data.Vector.Storable as Storable
import qualified Data.Vector.Unboxed as Unboxed
import Foreign.Ptr
import Foreign.Storable
import Text.Printf

import Test.Tasty
import Test.Tasty.HUnit (testCase, Assertion, assertBool, assertEqual, (@=?), assertFailure)


newtype Aligned a = Aligned { getAligned :: a }

instance (Storable a) => Storable (Aligned a) where
  sizeOf _    = sizeOf (undefined :: a)
  alignment _ = 128
  peek ptr    = Aligned Applicative.<$> peek (castPtr ptr)
  poke ptr    = poke (castPtr ptr) . getAligned

checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion
checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do
  let ptr'  = ptrToWordPtr ptr
      msg   = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr')
      align :: WordPtr
      align = fromIntegral $ alignment dummy
  assertBool msg $ (ptr' `mod` align) == 0
  where
    dummy :: a
    dummy = undefined

withBoundsChecksOnly :: [TestTree] -> [TestTree]
withBoundsChecksOnly ts =
  if Check.doChecks Check.Bounds
     then ts
     else []

tests :: [TestTree]
tests =
  [ testGroup "Data.Vector.Storable.Vector Alignment"
      [ testCase "Aligned Double" $
          checkAddressAlignment alignedDoubleVec
      , testCase "Aligned Int" $
          checkAddressAlignment alignedIntVec
      ]
  , testGroup "Regression tests"
    [ testGroup "enumFromTo crash #188"
      [ regression188 ([] :: [Word8])
      , regression188 ([] :: [Word16])
      , regression188 ([] :: [Word32])
      , regression188 ([] :: [Word64])
      , regression188 ([] :: [Word])
      , regression188 ([] :: [Int8])
      , regression188 ([] :: [Int16])
      , regression188 ([] :: [Int32])
      , regression188 ([] :: [Int64])
      , regression188 ([] :: [Int])
      , regression188 ([] :: [Char])
      ]
    ]
  , testGroup "Negative tests" $
    withBoundsChecksOnly [ testGroup "slice out of bounds #257"
      [ testGroup "Boxed" $ testsSliceOutOfBounds Boxed.slice
      , testGroup "Primitive" $ testsSliceOutOfBounds Primitive.slice
      , testGroup "Storable" $ testsSliceOutOfBounds Storable.slice
      , testGroup "Unboxed" $ testsSliceOutOfBounds Unboxed.slice
      ]]
    ++
    [ testGroup "take #282"
      [ testCase "Boxed" $ testTakeOutOfMemory Boxed.take
      , testCase "Primitive" $ testTakeOutOfMemory Primitive.take
      , testCase "Storable" $ testTakeOutOfMemory Storable.take
      , testCase "Unboxed" $ testTakeOutOfMemory Unboxed.take
      ]
    ]
  , testGroup "Data.Vector"
    [ testCase "MonadFix" checkMonadFix
    , testCase "toFromArray" toFromArray
    , testCase "toFromMutableArray" toFromMutableArray
    ]
  ]

testsSliceOutOfBounds ::
     (Show (v Int), Generic.Vector v Int) => (Int -> Int -> v Int -> v Int) -> [TestTree]
testsSliceOutOfBounds sliceWith =
  [ testCase "Negative ix" $ sliceTest sliceWith (-2) 2 xs
  , testCase "Negative size" $ sliceTest sliceWith 2 (-2) xs
  , testCase "Negative ix and size" $ sliceTest sliceWith (-2) (-1) xs
  , testCase "Too large ix" $ sliceTest sliceWith 6 2 xs
  , testCase "Too large size" $ sliceTest sliceWith 2 6 xs
  , testCase "Too large ix and size" $ sliceTest sliceWith 6 6 xs
  , testCase "Overflow" $ sliceTest sliceWith 1 maxBound xs
  , testCase "OutOfMemory" $ sliceTest sliceWith 1 (maxBound `div` intSize) xs
  ]
  where
    intSize = sizeOf (undefined :: Int)
    xs = [1, 2, 3, 4, 5] :: [Int]
{-# INLINE testsSliceOutOfBounds #-}

sliceTest ::
     (Show (v Int), Generic.Vector v Int)
  => (Int -> Int -> v Int -> v Int)
  -> Int
  -> Int
  -> [Int]
  -> Assertion
sliceTest sliceWith i m xs = do
  let vec = Generic.fromList xs
  eRes <- try (pure $! sliceWith i m vec)
  case eRes of
    Right v ->
      assertFailure $
      "Data.Vector.Internal.Check.checkSlice failed to check: " ++ show v
    Left (ErrorCall err) ->
      let assertMsg =
            List.concat
              [ "Expected slice function to produce an 'error' ending with: \""
              , errSuffix
              , "\" instead got: \""
              , err
              ]
       in assertBool assertMsg (errSuffix `List.isSuffixOf` err)
  where
    errSuffix =
      "(slice): invalid slice (" ++
      show i ++ "," ++ show m ++ "," ++ show (List.length xs) ++ ")"
{-# INLINE sliceTest #-}

testTakeOutOfMemory ::
     (Show (v Int), Eq (v Int), Generic.Vector v Int) => (Int -> v Int -> v Int) -> Assertion
testTakeOutOfMemory takeWith =
  takeWith (maxBound `div` intSize) (Generic.fromList xs) @=? Generic.fromList xs
  where
    intSize = sizeOf (undefined :: Int)
    xs = [1, 2, 3, 4, 5] :: [Int]
{-# INLINE testTakeOutOfMemory #-}

regression188
  :: forall proxy a. (Typeable a, Enum a, Bounded a, Eq a, Show a)
  => proxy a -> TestTree
regression188 _ = testCase (show (typeOf (undefined :: a)))
  $ Boxed.fromList [maxBound::a] @=? Boxed.enumFromTo maxBound maxBound
{-# INLINE regression188 #-}

alignedDoubleVec :: Storable.Vector (Aligned Double)
alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5]

alignedIntVec :: Storable.Vector (Aligned Int)
alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5]

#if __GLASGOW_HASKELL__ >= 800
-- Ensure that Mutable is really an injective type family by typechecking a
-- function which relies on injectivity.
_f :: (Generic.Vector v a, Generic.Vector w a, PrimMonad f)
   => Generic.Mutable v (PrimState f) a -> f (w a)
_f v = Generic.convert `fmap` Generic.unsafeFreeze v
#endif

checkMonadFix :: Assertion
checkMonadFix = assertBool "checkMonadFix" $
    Boxed.toList fewV == fewL &&
    Boxed.toList none == []
  where
    facty _ 0 = 1; facty f n = n * f (n - 1)
    fewV :: Boxed.Vector Int
    fewV = fmap ($ 12) $ mfix (\i -> Boxed.fromList [facty i, facty (+1), facty (+2)])
    fewL :: [Int]
    fewL = fmap ($ 12) $ mfix (\i -> [facty i, facty (+1), facty (+2)])
    none :: Boxed.Vector Int
    none = mfix (const Boxed.empty)

mkArrayRoundtrip :: (String -> Boxed.Vector Integer -> Assertion) -> Assertion
mkArrayRoundtrip mkAssertion =
  sequence_
    [ mkAssertion name v
    | (name, v) <-
        [ ("full", vec)
        , ("slicedTail", Boxed.slice 0 (n - 3) vec)
        , ("slicedHead", Boxed.slice 2 (n - 2) vec)
        , ("slicedBoth", Boxed.slice 2 (n - 4) vec)
        ]
    ]
  where
    vec = Boxed.fromList [0 .. 10]
    n = Boxed.length vec

toFromArray :: Assertion
toFromArray =
  mkArrayRoundtrip $ \name v ->
    assertEqual name v $ Boxed.fromArray (Boxed.toArray v)

toFromMutableArray :: Assertion
toFromMutableArray = mkArrayRoundtrip assetRoundtrip
  where
    assetRoundtrip assertionName vec = do
      mvec <- Boxed.unsafeThaw vec
      mvec' <- MBoxed.fromMutableArray =<< MBoxed.toMutableArray mvec
      vec' <- Boxed.unsafeFreeze mvec'
      assertEqual assertionName vec vec'