From 2135f122f2c936390e45725af17399bdb76b64c2 Mon Sep 17 00:00:00 2001
From: Alexey Kuleshevich <alexey@kuleshevi.ch>
Date: Thu, 30 Jan 2020 00:54:55 +0300
Subject: [PATCH] WIP: Fix #257

Fix the test case to trigger the sliceCheck
---
 Data/Vector/Internal/Check.hs   |  3 ++-
 tests/Tests/Vector/Unboxed.hs   |  2 +-
 tests/Tests/Vector/UnitTests.hs | 44 ++++++++++++++++++++++++++++++++-
 3 files changed, 46 insertions(+), 3 deletions(-)

diff --git a/Data/Vector/Internal/Check.hs b/Data/Vector/Internal/Check.hs
index 4a4ef80f..b8434435 100644
--- a/Data/Vector/Internal/Check.hs
+++ b/Data/Vector/Internal/Check.hs
@@ -148,5 +148,6 @@ checkSlice :: String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a
 {-# INLINE checkSlice #-}
 checkSlice file line kind loc i m n x
   = check file line kind loc (checkSlice_msg i m n)
-                             (i >= 0 && m >= 0 && i+m <= n) x
+--                             (i >= 0 && m >= 0 && i+m <= n) x
+                             (i >= 0 && m >= 0 && m <= n - i) x
 
diff --git a/tests/Tests/Vector/Unboxed.hs b/tests/Tests/Vector/Unboxed.hs
index 0f585fc8..b847e4b0 100644
--- a/tests/Tests/Vector/Unboxed.hs
+++ b/tests/Tests/Vector/Unboxed.hs
@@ -4,7 +4,7 @@ module Tests.Vector.Unboxed (tests) where
 import Test.Framework
 import qualified Data.Vector.Unboxed
 import Tests.Vector.Property
-import Data.Data
+
 
 testGeneralUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Data a) => Data.Vector.Unboxed.Vector a -> [Test]
 testGeneralUnboxedVector dummy = concatMap ($ dummy)
diff --git a/tests/Tests/Vector/UnitTests.hs b/tests/Tests/Vector/UnitTests.hs
index 57987b28..df7123b8 100644
--- a/tests/Tests/Vector/UnitTests.hs
+++ b/tests/Tests/Vector/UnitTests.hs
@@ -4,16 +4,23 @@
 module Tests.Vector.UnitTests (tests) where
 
 import Control.Applicative as Applicative
+import Control.Exception
 import Control.Monad.Primitive
+import Control.Monad.ST
+import qualified Data.List as List
 import qualified Data.Vector.Generic  as Generic
+import qualified Data.Vector.Generic.Mutable as MGeneric
+import qualified Data.Vector as Boxed
+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.Framework
 import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion, assertBool)
+import Test.HUnit (Assertion, assertBool, assertFailure)
 
 newtype Aligned a = Aligned { getAligned :: a }
 
@@ -42,8 +49,43 @@ tests =
       , testCase "Aligned Int" $
           checkAddressAlignment alignedIntVec
       ]
+  , testGroup "Regression tests"
+    [ testGroup "checkSlice (slice crash #257)"
+      [ testCase "Boxed" $ checkSliceOverflow Boxed.slice
+      , testCase "Primitive" $ checkSliceOverflow Primitive.slice
+      , testCase "Storable" $ checkSliceOverflow Storable.slice
+      , testCase "Unboxed" $ checkSliceOverflow Unboxed.slice
+      ]
+    ]
   ]
 
+checkSliceOverflow ::
+     Generic.Vector v Int => (Int -> Int -> v Int -> v Int) -> Assertion
+checkSliceOverflow slice' = do
+  eRes <- try (pure $! slice' 1 m vec)
+  case eRes of
+    Right _ ->
+      assertFailure "Data.Vector.Internal.Check.checkSlice has overflown"
+    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
+    m = maxBound :: Int
+    errSuffix =
+      "(slice): invalid slice (1," ++ show m ++ "," ++ show (length xs) ++ ")"
+    xs = [1, 2, 3, 4, 5] :: [Int]
+    -- Ensure vector is not build from a stream
+    vec = runST $ do
+      mv <- MGeneric.new 5
+      mapM_ (\(i, e) -> MGeneric.write mv i e) $ List.zip [0..] xs
+      Generic.freeze mv
+
 alignedDoubleVec :: Storable.Vector (Aligned Double)
 alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5]