Remove CPP driven error reporting in favor of HasCallStack

vector/include/vector.h

@@ -4,17 +4,5 @@
 #define INLINE_FUSED INLINE PHASE_FUSED
 #define INLINE_INNER INLINE PHASE_INNER
 
-#ifndef NOT_VECTOR_MODULE
-import qualified Data.Vector.Internal.Check as Ck
-#endif
-
-#define ERROR          (Ck.error __FILE__ __LINE__)
-#define INTERNAL_ERROR (Ck.internalError __FILE__ __LINE__)
-
-#define CHECK(f) (Ck.f __FILE__ __LINE__)
-#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 PHASE_STREAM  Please use "PHASE_FUSED" instead
 #define INLINE_STREAM Please use "INLINE_FUSED" instead

vector/src/Data/Vector/Fusion/Bundle/Monadic.hs

@@ -83,6 +83,7 @@ import Data.Vector.Fusion.Bundle.Size
 import Data.Vector.Fusion.Util ( Box(..), delay_inline, Id(..) )
 import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) )
 import qualified Data.Vector.Fusion.Stream.Monadic as S
+import Data.Vector.Internal.Check (check, Checks(..), HasCallStack)
 import Control.Monad.Primitive
 
 import qualified Data.List as List
@@ -847,16 +848,14 @@ enumFromTo_small x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact
 -- 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. (HasCallStack, Monad m) => Int -> Int -> Bundle m v Int
 {-# INLINE_FUSED enumFromTo_int #-}
 enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y))
   where
     {-# INLINE [0] len #-}
-    len :: Int -> Int -> Int
+    len :: HasCallStack => Int -> Int -> Int
     len u v | u > v     = 0
-            | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large"
-                          (n > 0)
-                        $ n
+            | otherwise = check Bounds "vector too large" (n > 0) n
       where
         n = v-u+1
 
@@ -866,13 +865,14 @@ enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (l
                   | z <  y    = return $ Yield z (Just (z+1))
                   | otherwise = return $ Done
 
-enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Bundle m v a
+enumFromTo_intlike :: forall m v a. (HasCallStack, Integral a, Monad m) => a -> a -> Bundle m v a
 {-# INLINE_FUSED enumFromTo_intlike #-}
 enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y))
   where
     {-# INLINE [0] len #-}
+    len :: HasCallStack => a -> a -> Int
     len u v | u > v     = 0
-            | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large"
+            | otherwise = check Bounds "vector too large"
                           (n > 0)
                         $ fromIntegral n
       where
@@ -903,13 +903,14 @@ enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exac
 
 
 
-enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Bundle m v a
+enumFromTo_big_word :: forall m v a. (HasCallStack, Integral a, Monad m) => a -> a -> Bundle m v a
 {-# INLINE_FUSED enumFromTo_big_word #-}
 enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y))
   where
     {-# INLINE [0] len #-}
+    len :: HasCallStack => a -> a -> Int
     len u v | u > v     = 0
-            | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large"
+            | otherwise = check Bounds "vector too large"
                           (n < fromIntegral (maxBound :: Int))
                         $ fromIntegral (n+1)
       where
@@ -946,13 +947,14 @@ enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exa
 #if WORD_SIZE_IN_BITS > 32
 
 -- FIXME: the "too large" test is totally wrong
-enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Bundle m v a
+enumFromTo_big_int :: forall m v a. (HasCallStack, Integral a, Monad m) => a -> a -> Bundle m v a
 {-# INLINE_FUSED enumFromTo_big_int #-}
 enumFromTo_big_int x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y))
   where
     {-# INLINE [0] len #-}
+    len :: HasCallStack => a -> a -> Int
     len u v | u > v     = 0
-            | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large"
+            | otherwise = check Bounds "vector too large"
                           (n > 0 && n <= fromIntegral (maxBound :: Int))
                         $ fromIntegral n
       where
@@ -999,17 +1001,16 @@ enumFromTo_char x y = x `seq` y `seq` fromStream (Stream step xn) (Exact n)
 -- Specialise enumFromTo for Float and Double.
 -- Also, try to do something about pairs?
 
-enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Bundle m v a
+enumFromTo_double :: forall m v a. (HasCallStack, Monad m, Ord a, RealFrac a) => a -> a -> Bundle m v a
 {-# INLINE_FUSED enumFromTo_double #-}
 enumFromTo_double n m = n `seq` m `seq` fromStream (Stream step ini) (Max (len n lim))
   where
     lim = m + 1/2 -- important to float out
 
     {-# INLINE [0] len #-}
+    len :: HasCallStack => a -> a -> Int
     len x y | x > y     = 0
-            | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large"
-                          (l > 0)
-                        $ fromIntegral l
+            | otherwise = check Bounds "vector too large" (l > 0) $ fromIntegral l
       where
         l :: Integer
         l = truncate (y-x)+2
@@ -1115,11 +1116,13 @@ fromVectors us = Bundle (Stream pstep (Left us))
                                Box x -> return $ Yield x (Right (v,i+1,vs))
 
     -- FIXME: work around bug in GHC 7.6.1
-    vstep :: [v a] -> m (Step [v a] (Chunk v a))
+    vstep :: HasCallStack => [v a] -> m (Step [v a] (Chunk v a))
     vstep [] = return Done
     vstep (v:vs) = return $ Yield (Chunk (basicLength v)
-                                         (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch"
-                                                                       (M.basicLength mv == basicLength v)
+                                         (\mv -> check
+                                                 Internal
+                                                 "length mismatch"
+                                                 (M.basicLength mv == basicLength v)
                                                  $ stToPrim $ basicUnsafeCopy mv v)) vs
 
 
@@ -1148,8 +1151,10 @@ concatVectors Bundle{sElems = Stream step t}
       r <- step s
       case r of
         Yield v s' -> return (Yield (Chunk (basicLength v)
-                                           (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch"
-                                                                          (M.basicLength mv == basicLength v)
+                                           (\mv -> check
+                                                   Internal
+                                                   "length mismatch"
+                                                   (M.basicLength mv == basicLength v)
                                                    $ stToPrim $ basicUnsafeCopy mv v)) s')
         Skip    s' -> return (Skip s')
         Done       -> return Done

vector/src/Data/Vector/Fusion/Stream/Monadic.hs

@@ -77,6 +77,7 @@ import Data.Vector.Fusion.Util ( Box(..) )
 import Data.Char      ( ord )
 import GHC.Base       ( unsafeChr )
 import Control.Monad  ( liftM )
+import qualified Prelude
 import Prelude hiding ( length, null,
                         replicate, (++),
                         head, last, (!!),
@@ -95,6 +96,8 @@ import Data.Word ( Word8, Word16, Word32, Word64 )
 
 import GHC.Types ( SPEC(..) )
 
+import Data.Vector.Internal.Check (HasCallStack)
+
 #include "vector.h"
 #include "MachDeps.h"
 
@@ -106,7 +109,6 @@ emptyStream :: String
 {-# NOINLINE emptyStream #-}
 emptyStream = "empty stream"
 
-#define EMPTY_STREAM (\state -> ERROR state emptyStream)
 
 -- | Result of taking a single step in a stream
 data Step s a where
@@ -226,7 +228,7 @@ Stream stepa ta ++ Stream stepb tb = Stream step (Left ta)
 -- ------------------
 
 -- | First element of the 'Stream' or error if empty
-head :: Monad m => Stream m a -> m a
+head :: (HasCallStack, Monad m) => Stream m a -> m a
 {-# INLINE_FUSED head #-}
 head (Stream step t) = head_loop SPEC t
   where
@@ -236,12 +238,12 @@ head (Stream step t) = head_loop SPEC t
           case r of
             Yield x _  -> return x
             Skip    s' -> head_loop SPEC s'
-            Done       -> EMPTY_STREAM "head"
+            Done       -> error emptyStream
 
 
 
 -- | Last element of the 'Stream' or error if empty
-last :: Monad m => Stream m a -> m a
+last :: (HasCallStack, Monad m) => Stream m a -> m a
 {-# INLINE_FUSED last #-}
 last (Stream step t) = last_loop0 SPEC t
   where
@@ -251,7 +253,7 @@ last (Stream step t) = last_loop0 SPEC t
           case r of
             Yield x s' -> last_loop1 SPEC x s'
             Skip    s' -> last_loop0 SPEC   s'
-            Done       -> EMPTY_STREAM "last"
+            Done       -> error emptyStream
 
     last_loop1 !_ x s
       = do
@@ -263,9 +265,9 @@ last (Stream step t) = last_loop0 SPEC t
 
 infixl 9 !!
 -- | Element at the given position
-(!!) :: Monad m => Stream m a -> Int -> m a
+(!!) :: (HasCallStack, Monad m) => Stream m a -> Int -> m a
 {-# INLINE (!!) #-}
-Stream step t !! j | j < 0     = ERROR "!!" "negative index"
+Stream step t !! j | j < 0     = error $ "negative index (" Prelude.++ show j Prelude.++ ")"
                    | otherwise = index_loop SPEC t j
   where
     index_loop !_ s i
@@ -276,7 +278,7 @@ Stream step t !! j | j < 0     = ERROR "!!" "negative index"
             Yield x s' | i == 0    -> return x
                        | otherwise -> index_loop SPEC s' (i-1)
             Skip    s'             -> index_loop SPEC s' i
-            Done                   -> EMPTY_STREAM "!!"
+            Done                   -> error emptyStream
 
 infixl 9 !?
 -- | Element at the given position or 'Nothing' if out of bounds
@@ -306,7 +308,7 @@ slice :: Monad m => Int   -- ^ starting index
 slice i n s = take n (drop i s)
 
 -- | All but the last element
-init :: Monad m => Stream m a -> Stream m a
+init :: (HasCallStack, Monad m) => Stream m a -> Stream m a
 {-# INLINE_FUSED init #-}
 init (Stream step t) = Stream step' (Nothing, t)
   where
@@ -315,7 +317,7 @@ init (Stream step t) = Stream step' (Nothing, t)
                            case r of
                              Yield x s' -> Skip (Just x,  s')
                              Skip    s' -> Skip (Nothing, s')
-                             Done       -> EMPTY_STREAM "init"
+                             Done       -> error emptyStream
                          ) (step s)
 
     step' (Just x,  s) = liftM (\r ->
@@ -326,7 +328,7 @@ init (Stream step t) = Stream step' (Nothing, t)
                          ) (step s)
 
 -- | All but the first element
-tail :: Monad m => Stream m a -> Stream m a
+tail :: (HasCallStack, Monad m) => Stream m a -> Stream m a
 {-# INLINE_FUSED tail #-}
 tail (Stream step t) = Stream step' (Left t)
   where
@@ -335,7 +337,7 @@ tail (Stream step t) = Stream step' (Left t)
                         case r of
                           Yield _ s' -> Skip (Right s')
                           Skip    s' -> Skip (Left  s')
-                          Done       -> EMPTY_STREAM "tail"
+                          Done       -> error emptyStream
                       ) (step s)
 
     step' (Right s) = liftM (\r ->
@@ -439,7 +441,7 @@ unbox (Stream step t) = Stream step' t
                 case r of
                   Yield (Box x) s' -> return $ Yield x s'
                   Skip          s' -> return $ Skip    s'
-                  Done             -> return $ Done
+                  Done             -> return Done
 
 -- Zipping
 -- -------
@@ -496,7 +498,7 @@ zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
                                      z <- f x y
                                      return $ Yield z (sa, sb', Nothing)
                                  Skip    sb' -> return $ Skip (sa, sb', Just x)
-                                 Done        -> return $ Done
+                                 Done        -> return Done
 
 zipWithM_ :: Monad m => (a -> b -> m c) -> Stream m a -> Stream m b -> m ()
 {-# INLINE zipWithM_ #-}
@@ -899,7 +901,7 @@ foldl1 :: Monad m => (a -> a -> a) -> Stream m a -> m a
 foldl1 f = foldl1M (\a b -> return (f a b))
 
 -- | Left fold over a non-empty 'Stream' with a monadic operator
-foldl1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a
+foldl1M :: (HasCallStack, Monad m) => (a -> a -> m a) -> Stream m a -> m a
 {-# INLINE_FUSED foldl1M #-}
 foldl1M f (Stream step t) = foldl1M_loop SPEC t
   where
@@ -909,7 +911,7 @@ foldl1M f (Stream step t) = foldl1M_loop SPEC t
           case r of
             Yield x s' -> foldlM f x (Stream step s')
             Skip    s' -> foldl1M_loop SPEC s'
-            Done       -> EMPTY_STREAM "foldl1M"
+            Done       -> error emptyStream
 
 -- | Same as 'foldl1M'
 fold1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a
@@ -947,7 +949,7 @@ foldl1' f = foldl1M' (\a b -> return (f a b))
 
 -- | Left fold over a non-empty 'Stream' with a strict accumulator and a
 -- monadic operator
-foldl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> m a
+foldl1M' :: (HasCallStack, Monad m) => (a -> a -> m a) -> Stream m a -> m a
 {-# INLINE_FUSED foldl1M' #-}
 foldl1M' f (Stream step t) = foldl1M'_loop SPEC t
   where
@@ -957,7 +959,7 @@ foldl1M' f (Stream step t) = foldl1M'_loop SPEC t
           case r of
             Yield x s' -> foldlM' f x (Stream step s')
             Skip    s' -> foldl1M'_loop SPEC s'
-            Done       -> EMPTY_STREAM "foldl1M'"
+            Done       -> error emptyStream
 
 -- | Same as 'foldl1M''
 fold1M' :: Monad m => (a -> a -> m a) -> Stream m a -> m a
@@ -988,7 +990,7 @@ foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m a
 foldr1 f = foldr1M (\a b -> return (f a b))
 
 -- | Right fold over a non-empty stream with a monadic operator
-foldr1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a
+foldr1M :: (HasCallStack, Monad m) => (a -> a -> m a) -> Stream m a -> m a
 {-# INLINE_FUSED foldr1M #-}
 foldr1M f (Stream step t) = foldr1M_loop0 SPEC t
   where
@@ -998,7 +1000,7 @@ foldr1M f (Stream step t) = foldr1M_loop0 SPEC t
           case r of
             Yield x s' -> foldr1M_loop1 SPEC x s'
             Skip    s' -> foldr1M_loop0 SPEC   s'
-            Done       -> EMPTY_STREAM "foldr1M"
+            Done       -> error emptyStream
 
     foldr1M_loop1 !_ x s
       = do
@@ -1685,4 +1687,3 @@ reVector (Stream step s, sSize = n} = Stream step s n
 
 
 -}
-