From 8d4ef48a724e13b4657e9cb4e482ea36d9526324 Mon Sep 17 00:00:00 2001
From: Bodigrim <andrew.lelechenko@gmail.com>
Date: Wed, 17 Nov 2021 21:14:07 +0000
Subject: [PATCH] Add HasCallStack for partial functions

---
 Data/ByteString.hs                | 29 +++++++++++++++--------------
 Data/ByteString/Lazy.hs           | 29 +++++++++++++++--------------
 Data/ByteString/Short/Internal.hs |  7 ++++---
 3 files changed, 34 insertions(+), 31 deletions(-)

diff --git a/Data/ByteString.hs b/Data/ByteString.hs
index 15ff4ae7d..78f334dfe 100644
--- a/Data/ByteString.hs
+++ b/Data/ByteString.hs
@@ -264,6 +264,7 @@ import GHC.IO.BufferedIO as Buffered
 import GHC.IO.Encoding          (getFileSystemEncoding)
 import GHC.IO                   (unsafePerformIO, unsafeDupablePerformIO)
 import GHC.Foreign              (newCStringLen, peekCStringLen)
+import GHC.Stack.Types          (HasCallStack)
 import Data.Char                (ord)
 import Foreign.Marshal.Utils    (copyBytes)
 
@@ -398,7 +399,7 @@ snoc (BS x l) c = unsafeCreate (l+1) $ \p -> unsafeWithForeignPtr x $ \f -> do
 
 -- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.
 -- An exception will be thrown in the case of an empty ByteString.
-head :: ByteString -> Word8
+head :: HasCallStack => ByteString -> Word8
 head (BS x l)
     | l <= 0    = errorEmptyList "head"
     | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p -> peek p
@@ -406,7 +407,7 @@ head (BS x l)
 
 -- | /O(1)/ Extract the elements after the head of a ByteString, which must be non-empty.
 -- An exception will be thrown in the case of an empty ByteString.
-tail :: ByteString -> ByteString
+tail :: HasCallStack => ByteString -> ByteString
 tail (BS p l)
     | l <= 0    = errorEmptyList "tail"
     | otherwise = BS (plusForeignPtr p 1) (l-1)
@@ -424,7 +425,7 @@ uncons (BS x l)
 
 -- | /O(1)/ Extract the last element of a ByteString, which must be finite and non-empty.
 -- An exception will be thrown in the case of an empty ByteString.
-last :: ByteString -> Word8
+last :: HasCallStack => ByteString -> Word8
 last ps@(BS x l)
     | null ps   = errorEmptyList "last"
     | otherwise = accursedUnutterablePerformIO $
@@ -433,7 +434,7 @@ last ps@(BS x l)
 
 -- | /O(1)/ Return all the elements of a 'ByteString' except the last one.
 -- An exception will be thrown in the case of an empty ByteString.
-init :: ByteString -> ByteString
+init :: HasCallStack => ByteString -> ByteString
 init ps@(BS p l)
     | null ps   = errorEmptyList "init"
     | otherwise = BS p (l-1)
@@ -583,7 +584,7 @@ foldr' k v = \(BS fp len) ->
 -- | 'foldl1' is a variant of 'foldl' that has no starting value
 -- argument, and thus must be applied to non-empty 'ByteString's.
 -- An exception will be thrown in the case of an empty ByteString.
-foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldl1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldl1 f ps = case uncons ps of
   Nothing     -> errorEmptyList "foldl1"
   Just (h, t) -> foldl f h t
@@ -591,7 +592,7 @@ foldl1 f ps = case uncons ps of
 
 -- | 'foldl1'' is like 'foldl1', but strict in the accumulator.
 -- An exception will be thrown in the case of an empty ByteString.
-foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldl1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldl1' f ps = case uncons ps of
   Nothing     -> errorEmptyList "foldl1'"
   Just (h, t) -> foldl' f h t
@@ -600,7 +601,7 @@ foldl1' f ps = case uncons ps of
 -- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
 -- and thus must be applied to non-empty 'ByteString's
 -- An exception will be thrown in the case of an empty ByteString.
-foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldr1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldr1 f ps = case unsnoc ps of
   Nothing -> errorEmptyList "foldr1"
   Just (b, c) -> foldr f c b
@@ -608,7 +609,7 @@ foldr1 f ps = case unsnoc ps of
 
 -- | 'foldr1'' is a variant of 'foldr1', but is strict in the
 -- accumulator.
-foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldr1' f ps = case unsnoc ps of
   Nothing -> errorEmptyList "foldr1'"
   Just (b, c) -> foldr' f c b
@@ -683,7 +684,7 @@ all f (BS x len) = accursedUnutterablePerformIO $ unsafeWithForeignPtr x g
 
 -- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString'
 -- An exception will be thrown in the case of an empty ByteString.
-maximum :: ByteString -> Word8
+maximum :: HasCallStack => ByteString -> Word8
 maximum xs@(BS x l)
     | null xs   = errorEmptyList "maximum"
     | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p ->
@@ -692,7 +693,7 @@ maximum xs@(BS x l)
 
 -- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString'
 -- An exception will be thrown in the case of an empty ByteString.
-minimum :: ByteString -> Word8
+minimum :: HasCallStack => ByteString -> Word8
 minimum xs@(BS x l)
     | null xs   = errorEmptyList "minimum"
     | otherwise = accursedUnutterablePerformIO $ unsafeWithForeignPtr x $ \p ->
@@ -1238,7 +1239,7 @@ intercalateWithByte c f@(BS ffp l) g@(BS fgp m) = unsafeCreate len $ \ptr ->
 -- Indexing ByteStrings
 
 -- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0.
-index :: ByteString -> Int -> Word8
+index :: HasCallStack => ByteString -> Int -> Word8
 index ps n
     | n < 0          = moduleError "index" ("negative index: " ++ show n)
     | n >= length ps = moduleError "index" ("index too large: " ++ show n
@@ -2009,15 +2010,15 @@ appendFile = modifyFile AppendMode
 
 -- Common up near identical calls to `error' to reduce the number
 -- constant strings created when compiled:
-errorEmptyList :: String -> a
+errorEmptyList :: HasCallStack => String -> a
 errorEmptyList fun = moduleError fun "empty ByteString"
 {-# NOINLINE errorEmptyList #-}
 
-moduleError :: String -> String -> a
+moduleError :: HasCallStack => String -> String -> a
 moduleError fun msg = error (moduleErrorMsg fun msg)
 {-# NOINLINE moduleError #-}
 
-moduleErrorIO :: String -> String -> IO a
+moduleErrorIO :: HasCallStack => String -> String -> IO a
 moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg
 {-# NOINLINE moduleErrorIO #-}
 
diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs
index 53458117a..9830810e0 100644
--- a/Data/ByteString/Lazy.hs
+++ b/Data/ByteString/Lazy.hs
@@ -239,6 +239,7 @@ import Data.ByteString.Lazy.Internal
 import Control.Monad            (mplus)
 import Data.Word                (Word8)
 import Data.Int                 (Int64)
+import GHC.Stack.Types          (HasCallStack)
 import System.IO                (Handle,openBinaryFile,stdin,stdout,withBinaryFile,IOMode(..)
                                 ,hClose)
 import System.IO.Error          (mkIOError, illegalOperationErrorType)
@@ -341,7 +342,7 @@ snoc cs w = foldrChunks Chunk (singleton w) cs
 {-# INLINE snoc #-}
 
 -- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.
-head :: ByteString -> Word8
+head :: HasCallStack => ByteString -> Word8
 head Empty       = errorEmptyList "head"
 head (Chunk c _) = S.unsafeHead c
 {-# INLINE head #-}
@@ -357,7 +358,7 @@ uncons (Chunk c cs)
 
 -- | /O(1)/ Extract the elements after the head of a ByteString, which must be
 -- non-empty.
-tail :: ByteString -> ByteString
+tail :: HasCallStack => ByteString -> ByteString
 tail Empty          = errorEmptyList "tail"
 tail (Chunk c cs)
   | S.length c == 1 = cs
@@ -366,7 +367,7 @@ tail (Chunk c cs)
 
 -- | /O(n\/c)/ Extract the last element of a ByteString, which must be finite
 -- and non-empty.
-last :: ByteString -> Word8
+last :: HasCallStack => ByteString -> Word8
 last Empty          = errorEmptyList "last"
 last (Chunk c0 cs0) = go c0 cs0
   where go c Empty        = S.unsafeLast c
@@ -374,7 +375,7 @@ last (Chunk c0 cs0) = go c0 cs0
 -- XXX Don't inline this. Something breaks with 6.8.2 (haven't investigated yet)
 
 -- | /O(n\/c)/ Return all the elements of a 'ByteString' except the last one.
-init :: ByteString -> ByteString
+init :: HasCallStack => ByteString -> ByteString
 init Empty          = errorEmptyList "init"
 init (Chunk c0 cs0) = go c0 cs0
   where go c Empty | S.length c == 1 = Empty
@@ -474,18 +475,18 @@ foldr' f a = go
 
 -- | 'foldl1' is a variant of 'foldl' that has no starting value
 -- argument, and thus must be applied to non-empty 'ByteString's.
-foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldl1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldl1 _ Empty        = errorEmptyList "foldl1"
 foldl1 f (Chunk c cs) = foldl f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs)
 
 -- | 'foldl1'' is like 'foldl1', but strict in the accumulator.
-foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldl1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldl1' _ Empty        = errorEmptyList "foldl1'"
 foldl1' f (Chunk c cs) = foldl' f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs)
 
 -- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
 -- and thus must be applied to non-empty 'ByteString's
-foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldr1 :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldr1 _ Empty          = errorEmptyList "foldr1"
 foldr1 f (Chunk c0 cs0) = go c0 cs0
   where go c Empty         = S.foldr1 f c
@@ -494,7 +495,7 @@ foldr1 f (Chunk c0 cs0) = go c0 cs0
 -- | 'foldr1'' is like 'foldr1', but strict in the accumulator.
 --
 -- @since 0.11.2.0
-foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
+foldr1' :: HasCallStack => (Word8 -> Word8 -> Word8) -> ByteString -> Word8
 foldr1' _ Empty          = errorEmptyList "foldr1'"
 foldr1' f (Chunk c0 cs0) = go c0 cs0
   where go c Empty         = S.foldr1' f c
@@ -535,14 +536,14 @@ all f = foldrChunks (\c rest -> S.all f c && rest) True
 {-# INLINE all #-}
 
 -- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString'
-maximum :: ByteString -> Word8
+maximum :: HasCallStack => ByteString -> Word8
 maximum Empty        = errorEmptyList "maximum"
 maximum (Chunk c cs) = foldlChunks (\n c' -> n `max` S.maximum c')
                                    (S.maximum c) cs
 {-# INLINE maximum #-}
 
 -- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString'
-minimum :: ByteString -> Word8
+minimum :: HasCallStack => ByteString -> Word8
 minimum Empty        = errorEmptyList "minimum"
 minimum (Chunk c cs) = foldlChunks (\n c' -> n `min` S.minimum c')
                                      (S.minimum c) cs
@@ -715,7 +716,7 @@ replicate n w
 -- | 'cycle' ties a finite ByteString into a circular one, or equivalently,
 -- the infinite repetition of the original ByteString.
 --
-cycle :: ByteString -> ByteString
+cycle :: HasCallStack => ByteString -> ByteString
 cycle Empty = errorEmptyList "cycle"
 cycle cs    = cs' where cs' = foldrChunks Chunk cs' cs
 
@@ -1122,7 +1123,7 @@ intercalate s = concat . List.intersperse s
 -- Indexing ByteStrings
 
 -- | /O(c)/ 'ByteString' index (subscript) operator, starting from 0.
-index :: ByteString -> Int64 -> Word8
+index :: HasCallStack => ByteString -> Int64 -> Word8
 index _  i | i < 0  = moduleError "index" ("negative index: " ++ show i)
 index cs0 i         = index' cs0 i
   where index' Empty     n = moduleError "index" ("index too large: " ++ show n)
@@ -1613,11 +1614,11 @@ interact transformer = putStr . transformer =<< getContents
 
 -- Common up near identical calls to `error' to reduce the number
 -- constant strings created when compiled:
-errorEmptyList :: String -> a
+errorEmptyList :: HasCallStack => String -> a
 errorEmptyList fun = moduleError fun "empty ByteString"
 {-# NOINLINE errorEmptyList #-}
 
-moduleError :: String -> String -> a
+moduleError :: HasCallStack => String -> String -> a
 moduleError fun msg = error ("Data.ByteString.Lazy." ++ fun ++ ':':' ':msg)
 {-# NOINLINE moduleError #-}
 
diff --git a/Data/ByteString/Short/Internal.hs b/Data/ByteString/Short/Internal.hs
index 6b4f9497c..4e30656a8 100644
--- a/Data/ByteString/Short/Internal.hs
+++ b/Data/ByteString/Short/Internal.hs
@@ -81,6 +81,7 @@ import GHC.Exts ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#)
 import GHC.IO
 import GHC.ForeignPtr (ForeignPtr(ForeignPtr), ForeignPtrContents(PlainPtr))
 import GHC.ST         (ST(ST), runST)
+import GHC.Stack.Types (HasCallStack)
 import GHC.Word
 
 import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..)
@@ -194,7 +195,7 @@ null :: ShortByteString -> Bool
 null sbs = length sbs == 0
 
 -- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0.
-index :: ShortByteString -> Int -> Word8
+index :: HasCallStack => ShortByteString -> Int -> Word8
 index sbs i
   | i >= 0 && i < length sbs = unsafeIndex sbs i
   | otherwise                = indexError sbs i
@@ -222,7 +223,7 @@ indexMaybe sbs i
 unsafeIndex :: ShortByteString -> Int -> Word8
 unsafeIndex sbs = indexWord8Array (asBA sbs)
 
-indexError :: ShortByteString -> Int -> a
+indexError :: HasCallStack => ShortByteString -> Int -> a
 indexError sbs i =
   error $ "Data.ByteString.Short.index: error in array index; " ++ show i
        ++ " not in range [0.." ++ show (length sbs) ++ ")"
@@ -601,7 +602,7 @@ useAsCStringLen bs action =
 -- ---------------------------------------------------------------------
 -- Internal utilities
 
-moduleErrorIO :: String -> String -> IO a
+moduleErrorIO :: HasCallStack => String -> String -> IO a
 moduleErrorIO fun msg = throwIO . userError $ moduleErrorMsg fun msg
 {-# NOINLINE moduleErrorIO #-}