diff --git a/Data/Vector.hs b/Data/Vector.hs
index 5c04b412..73ca3010 100644
--- a/Data/Vector.hs
+++ b/Data/Vector.hs
@@ -213,6 +213,9 @@ import qualified GHC.Exts as Exts (IsList(..))
#endif
+#include "stacktracetools.h"
+
+
-- | Boxed vectors, supporting efficient slicing.
data Vector a = Vector {-# UNPACK #-} !Int
{-# UNPACK #-} !Int
@@ -450,7 +453,7 @@ null = G.null
-- --------
-- | O(1) Indexing
-(!) :: Vector a -> Int -> a
+(!) :: HasCallStack => Vector a -> Int -> a
{-# INLINE (!) #-}
(!) = (G.!)
@@ -460,12 +463,12 @@ null = G.null
(!?) = (G.!?)
-- | /O(1)/ First element
-head :: Vector a -> a
+head :: HasCallStack => Vector a -> a
{-# INLINE head #-}
head = G.head
-- | /O(1)/ Last element
-last :: Vector a -> a
+last :: HasCallStack => Vector a -> a
{-# INLINE last #-}
last = G.last
@@ -506,19 +509,19 @@ unsafeLast = G.unsafeLast
-- Here, no references to @v@ are retained because indexing (but /not/ the
-- elements) is evaluated eagerly.
--
-indexM :: Monad m => Vector a -> Int -> m a
+indexM :: (Monad m, HasCallStack) => Vector a -> Int -> m a
{-# INLINE indexM #-}
indexM = G.indexM
-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
-headM :: Monad m => Vector a -> m a
+headM :: (Monad m, HasCallStack) => Vector a -> m a
{-# INLINE headM #-}
headM = G.headM
-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
-lastM :: Monad m => Vector a -> m a
+lastM :: (Monad m, HasCallStack) => Vector a -> m a
{-# INLINE lastM #-}
lastM = G.lastM
@@ -545,7 +548,8 @@ unsafeLastM = G.unsafeLastM
-- | /O(1)/ Yield a slice of the vector without copying it. The vector must
-- contain at least @i+n@ elements.
-slice :: Int -- ^ @i@ starting index
+slice :: HasCallStack
+ => Int -- ^ @i@ starting index
-> Int -- ^ @n@ length
-> Vector a
-> Vector a
@@ -554,13 +558,13 @@ slice = G.slice
-- | /O(1)/ Yield all but the last element without copying. The vector may not
-- be empty.
-init :: Vector a -> Vector a
+init :: HasCallStack => Vector a -> Vector a
{-# INLINE init #-}
init = G.init
-- | /O(1)/ Yield all but the first element without copying. The vector may not
-- be empty.
-tail :: Vector a -> Vector a
+tail :: HasCallStack => Vector a -> Vector a
{-# INLINE tail #-}
tail = G.tail
diff --git a/Data/Vector/Fusion/Bundle/Monadic.hs b/Data/Vector/Fusion/Bundle/Monadic.hs
index 46f4a165..d2a257c1 100644
--- a/Data/Vector/Fusion/Bundle/Monadic.hs
+++ b/Data/Vector/Fusion/Bundle/Monadic.hs
@@ -115,6 +115,9 @@ import Data.Word ( Word )
import Data.Int ( Int64 )
#endif
+GHC_STACKTRACE_IMPORTS
+
+
data Chunk v a = Chunk Int (forall m. (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m ())
-- | Monadic streams
@@ -806,7 +809,7 @@ enumFromTo_small x y = x `seq` y `seq` fromStream (Stream step x) (Exact n)
-- unsigned types). See http://hackage.haskell.org/trac/ghc/ticket/3744
--
-enumFromTo_int :: forall m v. Monad m => Int -> Int -> Bundle m v Int
+enumFromTo_int :: forall m v. (Monad m, HasCallStack) => Int -> Int -> Bundle m v Int
{-# INLINE_FUSED enumFromTo_int #-}
enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y))
where
@@ -823,7 +826,7 @@ enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)
step z | z <= y = return $ Yield z (z+1)
| otherwise = return $ Done
-enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Bundle m v a
+enumFromTo_intlike :: (Integral a, Monad m, HasCallStack) => a -> a -> Bundle m v a
{-# INLINE_FUSED enumFromTo_intlike #-}
enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y))
where
@@ -858,7 +861,7 @@ enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len
-enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Bundle m v a
+enumFromTo_big_word :: (Integral a, Monad m, HasCallStack) => a -> a -> Bundle m v a
{-# INLINE_FUSED enumFromTo_big_word #-}
enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y))
where
diff --git a/Data/Vector/Generic.hs b/Data/Vector/Generic.hs
index cc568df1..b09f46fe 100644
--- a/Data/Vector/Generic.hs
+++ b/Data/Vector/Generic.hs
@@ -222,6 +222,9 @@ mkNoRepType = mkNorepType
import qualified Data.Traversable as T (Traversable(mapM))
+GHC_STACKTRACE_IMPORTS
+
+
-- Length information
-- ------------------
@@ -240,7 +243,7 @@ null = Bundle.null . stream
infixl 9 !
-- | O(1) Indexing
-(!) :: Vector v a => v a -> Int -> a
+(!) :: (Vector v a, HasCallStack) => v a -> Int -> a
{-# INLINE_FUSED (!) #-}
(!) v i = BOUNDS_CHECK(checkIndex) "(!)" i (length v)
$ unId (basicUnsafeIndexM v i)
@@ -253,7 +256,7 @@ v !? i | i < 0 || i >= length v = Nothing
| otherwise = Just $ unsafeIndex v i
-- | /O(1)/ First element
-head :: Vector v a => v a -> a
+head :: (Vector v a, HasCallStack) => v a -> a
{-# INLINE_FUSED head #-}
head v = v ! 0
@@ -325,20 +328,20 @@ unsafeLast v = unsafeIndex v (length v - 1)
-- Here, no references to @v@ are retained because indexing (but /not/ the
-- elements) is evaluated eagerly.
--
-indexM :: (Vector v a, Monad m) => v a -> Int -> m a
+indexM :: (Vector v a, Monad m, HasCallStack) => v a -> Int -> m a
{-# INLINE_FUSED indexM #-}
indexM v i = BOUNDS_CHECK(checkIndex) "indexM" i (length v)
$ basicUnsafeIndexM v i
-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
-headM :: (Vector v a, Monad m) => v a -> m a
+headM :: (Vector v a, Monad m, HasCallStack) => v a -> m a
{-# INLINE_FUSED headM #-}
headM v = indexM v 0
-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
-lastM :: (Vector v a, Monad m) => v a -> m a
+lastM :: (Vector v a, Monad m, HasCallStack) => v a -> m a
{-# INLINE_FUSED lastM #-}
lastM v = indexM v (length v - 1)
@@ -388,7 +391,8 @@ unsafeLastM v = unsafeIndexM v (length v - 1)
-- | /O(1)/ Yield a slice of the vector without copying it. The vector must
-- contain at least @i+n@ elements.
-slice :: Vector v a => Int -- ^ @i@ starting index
+slice :: (Vector v a, HasCallStack)
+ => Int -- ^ @i@ starting index
-> Int -- ^ @n@ length
-> v a
-> v a
@@ -398,13 +402,13 @@ slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v)
-- | /O(1)/ Yield all but the last element without copying. The vector may not
-- be empty.
-init :: Vector v a => v a -> v a
+init :: (Vector v a, HasCallStack) => v a -> v a
{-# INLINE_FUSED init #-}
init v = slice 0 (length v - 1) v
-- | /O(1)/ Yield all but the first element without copying. The vector may not
-- be empty.
-tail :: Vector v a => v a -> v a
+tail :: (Vector v a, HasCallStack) => v a -> v a
{-# INLINE_FUSED tail #-}
tail v = slice 1 (length v - 1) v
@@ -932,7 +936,7 @@ reverse = unstream . streamR
-- often much more efficient.
--
-- > backpermute <0,3,2,3,1,0> =
-backpermute :: (Vector v a, Vector v Int)
+backpermute :: (Vector v a, Vector v Int, HasCallStack)
=> v a -- ^ @xs@ value vector
-> v Int -- ^ @is@ index vector (of length @n@)
-> v a
@@ -1987,7 +1991,7 @@ thawMany vs = do
-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must
-- have the same length.
copy
- :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> v a -> m ()
+ :: (PrimMonad m, Vector v a, HasCallStack) => Mutable v (PrimState m) a -> v a -> m ()
{-# INLINE copy #-}
copy dst src = BOUNDS_CHECK(check) "copy" "length mismatch"
(M.length dst == length src)
diff --git a/Data/Vector/Generic/Mutable.hs b/Data/Vector/Generic/Mutable.hs
index c3f531d7..7fa28a7f 100644
--- a/Data/Vector/Generic/Mutable.hs
+++ b/Data/Vector/Generic/Mutable.hs
@@ -78,6 +78,8 @@ import Prelude hiding ( length, null, replicate, reverse, map, read,
#include "vector.h"
+GHC_STACKTRACE_IMPORTS
+
{-
type family Immutable (v :: * -> * -> *) :: * -> *
@@ -509,7 +511,7 @@ null v = length v == 0
-- ---------------------
-- | Yield a part of the mutable vector without copying it.
-slice :: MVector v a => Int -> Int -> v s a -> v s a
+slice :: (MVector v a, HasCallStack) => Int -> Int -> v s a -> v s a
{-# INLINE slice #-}
slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v)
$ unsafeSlice i n v
diff --git a/Data/Vector/Internal/Check.hs b/Data/Vector/Internal/Check.hs
index 4a4ef80f..17333bf7 100644
--- a/Data/Vector/Internal/Check.hs
+++ b/Data/Vector/Internal/Check.hs
@@ -26,6 +26,9 @@ import GHC.Prim( Int# )
import Prelude hiding( error, (&&), (||), not )
import qualified Prelude as P
+
+#include "stacktracetools.h"
+
-- NOTE: This is a workaround for GHC's weird behaviour where it doesn't inline
-- these functions into unfoldings which makes the intermediate code size
-- explode. See http://hackage.haskell.org/trac/ghc/ticket/5539.
@@ -81,12 +84,12 @@ doChecks Internal = doInternalChecks
error_msg :: String -> Int -> String -> String -> String
error_msg file line loc msg = file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg
-error :: String -> Int -> String -> String -> a
+error :: HasCallStack => String -> Int -> String -> String -> a
{-# NOINLINE error #-}
error file line loc msg
= P.error $ error_msg file line loc msg
-internalError :: String -> Int -> String -> String -> a
+internalError :: HasCallStack => String -> Int -> String -> String -> a
{-# NOINLINE internalError #-}
internalError file line loc msg
= P.error $ unlines
@@ -95,14 +98,14 @@ internalError file line loc msg
,error_msg file line loc msg]
-checkError :: String -> Int -> Checks -> String -> String -> a
+checkError :: HasCallStack => String -> Int -> Checks -> String -> String -> a
{-# NOINLINE checkError #-}
checkError file line kind loc msg
= case kind of
Internal -> internalError file line loc msg
_ -> error file line loc msg
-check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a
+check :: HasCallStack => String -> Int -> Checks -> String -> String -> Bool -> a -> a
{-# INLINE check #-}
check file line kind loc msg cond x
| not (doChecks kind) || cond = x
@@ -116,7 +119,7 @@ checkIndex_msg# :: Int# -> Int# -> String
{-# NOINLINE checkIndex_msg# #-}
checkIndex_msg# i# n# = "index out of bounds " ++ show (I# i#, I# n#)
-checkIndex :: String -> Int -> Checks -> String -> Int -> Int -> a -> a
+checkIndex :: HasCallStack => String -> Int -> Checks -> String -> Int -> Int -> a -> a
{-# INLINE checkIndex #-}
checkIndex file line kind loc i n x
= check file line kind loc (checkIndex_msg i n) (i >= 0 && i String
{-# NOINLINE checkLength_msg# #-}
checkLength_msg# n# = "negative length " ++ show (I# n#)
-checkLength :: String -> Int -> Checks -> String -> Int -> a -> a
+checkLength :: HasCallStack => String -> Int -> Checks -> String -> Int -> a -> a
{-# INLINE checkLength #-}
checkLength file line kind loc n x
= check file line kind loc (checkLength_msg n) (n >= 0) x
@@ -144,7 +147,7 @@ checkSlice_msg# :: Int# -> Int# -> Int# -> String
{-# NOINLINE checkSlice_msg# #-}
checkSlice_msg# i# m# n# = "invalid slice " ++ show (I# i#, I# m#, I# n#)
-checkSlice :: String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a
+checkSlice :: HasCallStack => 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)
diff --git a/Data/Vector/Unboxed.hs b/Data/Vector/Unboxed.hs
index 9f5ae6cd..2f4292d3 100644
--- a/Data/Vector/Unboxed.hs
+++ b/Data/Vector/Unboxed.hs
@@ -202,6 +202,9 @@ import qualified GHC.Exts as Exts (IsList(..))
#define NOT_VECTOR_MODULE
#include "vector.h"
+#include "stacktracetools.h"
+
+
-- See http://trac.haskell.org/vector/ticket/12
instance (Unbox a, Eq a) => Eq (Vector a) where
{-# INLINE (==) #-}
@@ -278,7 +281,7 @@ null = G.null
-- --------
-- | O(1) Indexing
-(!) :: Unbox a => Vector a -> Int -> a
+(!) :: (Unbox a, HasCallStack) => Vector a -> Int -> a
{-# INLINE (!) #-}
(!) = (G.!)
@@ -288,12 +291,12 @@ null = G.null
(!?) = (G.!?)
-- | /O(1)/ First element
-head :: Unbox a => Vector a -> a
+head :: (Unbox a, HasCallStack) => Vector a -> a
{-# INLINE head #-}
head = G.head
-- | /O(1)/ Last element
-last :: Unbox a => Vector a -> a
+last :: (Unbox a, HasCallStack) => Vector a -> a
{-# INLINE last #-}
last = G.last
@@ -334,19 +337,19 @@ unsafeLast = G.unsafeLast
-- Here, no references to @v@ are retained because indexing (but /not/ the
-- elements) is evaluated eagerly.
--
-indexM :: (Unbox a, Monad m) => Vector a -> Int -> m a
+indexM :: (Unbox a, Monad m, HasCallStack) => Vector a -> Int -> m a
{-# INLINE indexM #-}
indexM = G.indexM
-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
-headM :: (Unbox a, Monad m) => Vector a -> m a
+headM :: (Unbox a, Monad m, HasCallStack) => Vector a -> m a
{-# INLINE headM #-}
headM = G.headM
-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
-lastM :: (Unbox a, Monad m) => Vector a -> m a
+lastM :: (Unbox a, Monad m, HasCallStack) => Vector a -> m a
{-# INLINE lastM #-}
lastM = G.lastM
@@ -373,7 +376,8 @@ unsafeLastM = G.unsafeLastM
-- | /O(1)/ Yield a slice of the vector without copying it. The vector must
-- contain at least @i+n@ elements.
-slice :: Unbox a => Int -- ^ @i@ starting index
+slice :: (Unbox a, HasCallStack)
+ => Int -- ^ @i@ starting index
-> Int -- ^ @n@ length
-> Vector a
-> Vector a
@@ -382,13 +386,13 @@ slice = G.slice
-- | /O(1)/ Yield all but the last element without copying. The vector may not
-- be empty.
-init :: Unbox a => Vector a -> Vector a
+init :: (Unbox a, HasCallStack) => Vector a -> Vector a
{-# INLINE init #-}
init = G.init
-- | /O(1)/ Yield all but the first element without copying. The vector may not
-- be empty.
-tail :: Unbox a => Vector a -> Vector a
+tail :: (Unbox a, HasCallStack) => Vector a -> Vector a
{-# INLINE tail #-}
tail = G.tail
@@ -782,7 +786,7 @@ reverse = G.reverse
-- often much more efficient.
--
-- > backpermute <0,3,2,3,1,0> =
-backpermute :: Unbox a => Vector a -> Vector Int -> Vector a
+backpermute :: (Unbox a, HasCallStack) => Vector a -> Vector Int -> Vector a
{-# INLINE backpermute #-}
backpermute = G.backpermute
diff --git a/include/stacktracetools.h b/include/stacktracetools.h
new file mode 100644
index 00000000..6105a3a2
--- /dev/null
+++ b/include/stacktracetools.h
@@ -0,0 +1,6 @@
+#if MIN_VERSION_base(4,9,0)
+import GHC.Stack (HasCallStack)
+#define CHECK(f) (withFrozenCallStack Ck.f __FILE__ __LINE__)
+#else
+#define HasCallStack (Eq ())
+#endif
diff --git a/include/vector.h b/include/vector.h
index 1568bb29..170eb2a3 100644
--- a/include/vector.h
+++ b/include/vector.h
@@ -11,10 +11,18 @@ import qualified Data.Vector.Internal.Check as Ck
#define ERROR (Ck.error __FILE__ __LINE__)
#define INTERNAL_ERROR (Ck.internalError __FILE__ __LINE__)
-#define CHECK(f) (Ck.f __FILE__ __LINE__)
+#define UNTRACED_CHECK(f) (Ck.f __FILE__ __LINE__)
+#if MIN_VERSION_base(4,9,0)
+#define GHC_STACKTRACE_IMPORTS import GHC.Stack
+#define CHECK(f) (withFrozenCallStack Ck.f __FILE__ __LINE__)
+#else
+#define GHC_STACKTRACE_IMPORTS
+#define HasCallStack (Eq ())
+#define CHECK(f) UNTRACED_CHECK(f)
+#endif
#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds)
-#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe)
-#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal)
+#define UNSAFE_CHECK(f) (UNTRACED_CHECK(f) Ck.Unsafe)
+#define INTERNAL_CHECK(f) (UNTRACED_CHECK(f) Ck.Internal)
#define PHASE_STREAM Please use "PHASE_FUSED" instead
#define INLINE_STREAM Please use "INLINE_FUSED" instead
diff --git a/vector.cabal b/vector.cabal
index 326454cf..6a59320f 100644
--- a/vector.cabal
+++ b/vector.cabal
@@ -143,6 +143,7 @@ Library
Install-Includes:
vector.h
+ stacktracetools.h
Build-Depends: base >= 4.5 && < 4.11
, primitive >= 0.5.0.1 && < 0.7