diff options
Diffstat (limited to 'libraries')
65 files changed, 338 insertions, 229 deletions
diff --git a/libraries/array b/libraries/array -Subproject f643793b3fbffd7419f403bedc65b7ac06dff0c +Subproject 6551ad9edaca1634a8149ad9c27a72feb456d4e diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index babe8d9a76..e047662a9c 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -412,7 +412,7 @@ threadWaitRead fd return () -- hWaitForInput does work properly, but we can only -- do this for stdin since we know its FD. - _ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" + _ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" #else = GHC.Conc.threadWaitRead fd #endif @@ -428,7 +428,7 @@ threadWaitWrite :: Fd -> IO () threadWaitWrite fd #ifdef mingw32_HOST_OS | threaded = withThread (waitFd fd 1) - | otherwise = error "threadWaitWrite requires -threaded on Windows" + | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" #else = GHC.Conc.threadWaitWrite fd #endif @@ -452,7 +452,7 @@ threadWaitReadSTM fd Just (Left e) -> throwSTM (e :: IOException) let killAction = return () return (waitAction, killAction) - | otherwise = error "threadWaitReadSTM requires -threaded on Windows" + | otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows" #else = GHC.Conc.threadWaitReadSTM fd #endif @@ -476,7 +476,7 @@ threadWaitWriteSTM fd Just (Left e) -> throwSTM (e :: IOException) let killAction = return () return (waitAction, killAction) - | otherwise = error "threadWaitWriteSTM requires -threaded on Windows" + | otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows" #else = GHC.Conc.threadWaitWriteSTM fd #endif diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index ece5c69dd5..b609ef2095 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -401,8 +401,8 @@ recSelError, recConError, irrefutPatError, runtimeError, recSelError s = throw (RecSelError ("No match in record selector " ++ unpackCStringUtf8# s)) -- No location info unfortunately -runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately -absentError s = error ("Oops! Entered absent arg " ++ unpackCStringUtf8# s) +runtimeError s = errorWithoutStackTrace (unpackCStringUtf8# s) -- No location info unfortunately +absentError s = errorWithoutStackTrace ("Oops! Entered absent arg " ++ unpackCStringUtf8# s) nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern")) diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs index ae37911c18..6b78e90c89 100644 --- a/libraries/base/Control/Monad/Fix.hs +++ b/libraries/base/Control/Monad/Fix.hs @@ -28,7 +28,7 @@ import Data.Function ( fix ) import Data.Maybe import Data.Monoid ( Dual(..), Sum(..), Product(..) , First(..), Last(..), Alt(..) ) -import GHC.Base ( Monad, error, (.) ) +import GHC.Base ( Monad, errorWithoutStackTrace, (.) ) import GHC.List ( head, tail ) import GHC.ST import System.IO @@ -63,7 +63,7 @@ class (Monad m) => MonadFix m where instance MonadFix Maybe where mfix f = let a = f (unJust a) in a where unJust (Just x) = x - unJust Nothing = error "mfix Maybe: Nothing" + unJust Nothing = errorWithoutStackTrace "mfix Maybe: Nothing" instance MonadFix [] where mfix f = case fix (f . head) of @@ -79,7 +79,7 @@ instance MonadFix ((->) r) where instance MonadFix (Either e) where mfix f = let a = f (unRight a) in a where unRight (Right x) = x - unRight (Left _) = error "mfix Either: Left" + unRight (Left _) = errorWithoutStackTrace "mfix Either: Left" instance MonadFix (ST s) where mfix = fixST diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs index c99912e62d..51b1d86e09 100644 --- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs +++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs @@ -76,7 +76,7 @@ instance Applicative (ST s) where instance Monad (ST s) where - fail s = error s + fail s = errorWithoutStackTrace s (ST m) >>= k = ST $ \ s -> diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 9134e13ba8..3c319995b8 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -529,7 +529,7 @@ instance Bits Integer where rotate x i = shift x i -- since an Integer never wraps around bitSizeMaybe _ = Nothing - bitSize _ = error "Data.Bits.bitSize(Integer)" + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" isSigned _ = True ----------------------------------------------------------------------------- diff --git a/libraries/base/Data/Char.hs b/libraries/base/Data/Char.hs index c8dd9331c6..69e4db7018 100644 --- a/libraries/base/Data/Char.hs +++ b/libraries/base/Data/Char.hs @@ -97,7 +97,7 @@ digitToInt c | (fromIntegral dec::Word) <= 9 = dec | (fromIntegral hexl::Word) <= 5 = hexl + 10 | (fromIntegral hexu::Word) <= 5 = hexu + 10 - | otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh + | otherwise = errorWithoutStackTrace ("Char.digitToInt: not a digit " ++ show c) -- sigh where dec = ord c - ord '0' hexl = ord c - ord 'a' diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index c242566276..88191c1011 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -444,7 +444,7 @@ newtype Mp m x = Mp { unMp :: m (x, Bool) } -- | Build a term skeleton fromConstr :: Data a => Constr -> a -fromConstr = fromConstrB (error "Data.Data.fromConstr") +fromConstr = fromConstrB (errorWithoutStackTrace "Data.Data.fromConstr") -- | Build a term and use a generic function for subterms @@ -582,7 +582,7 @@ repConstr dt cr = (IntRep, IntConstr i) -> mkIntegralConstr dt i (FloatRep, FloatConstr f) -> mkRealConstr dt f (CharRep, CharConstr c) -> mkCharConstr dt c - _ -> error "Data.Data.repConstr: The given ConstrRep does not fit to the given DataType." + _ -> errorWithoutStackTrace "Data.Data.repConstr: The given ConstrRep does not fit to the given DataType." @@ -620,7 +620,7 @@ mkConstr dt str fields fix = dataTypeConstrs :: DataType -> [Constr] dataTypeConstrs dt = case datarep dt of (AlgRep cons) -> cons - _ -> error $ "Data.Data.dataTypeConstrs is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.dataTypeConstrs is not supported for " ++ dataTypeName dt ++ ", as it is not an algebraic data type." @@ -695,7 +695,7 @@ isAlgType dt = case datarep dt of indexConstr :: DataType -> ConIndex -> Constr indexConstr dt idx = case datarep dt of (AlgRep cs) -> cs !! (idx-1) - _ -> error $ "Data.Data.indexConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.indexConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an algebraic data type." @@ -704,7 +704,7 @@ indexConstr dt idx = case datarep dt of constrIndex :: Constr -> ConIndex constrIndex con = case constrRep con of (AlgConstr idx) -> idx - _ -> error $ "Data.Data.constrIndex is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.constrIndex is not supported for " ++ dataTypeName (constrType con) ++ ", as it is not an algebraic data type." @@ -713,7 +713,7 @@ constrIndex con = case constrRep con of maxConstrIndex :: DataType -> ConIndex maxConstrIndex dt = case dataTypeRep dt of AlgRep cs -> length cs - _ -> error $ "Data.Data.maxConstrIndex is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.maxConstrIndex is not supported for " ++ dataTypeName dt ++ ", as it is not an algebraic data type." @@ -755,21 +755,21 @@ mkPrimCon dt str cr = Constr { datatype = dt , conrep = cr , constring = str - , confields = error "Data.Data.confields" - , confixity = error "Data.Data.confixity" + , confields = errorWithoutStackTrace "Data.Data.confields" + , confixity = errorWithoutStackTrace "Data.Data.confixity" } mkIntegralConstr :: (Integral a, Show a) => DataType -> a -> Constr mkIntegralConstr dt i = case datarep dt of IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger i)) - _ -> error $ "Data.Data.mkIntegralConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.mkIntegralConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an Integral data type." mkRealConstr :: (Real a, Show a) => DataType -> a -> Constr mkRealConstr dt f = case datarep dt of FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f)) - _ -> error $ "Data.Data.mkRealConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.mkRealConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an Real data type." @@ -777,7 +777,7 @@ mkRealConstr dt f = case datarep dt of mkCharConstr :: DataType -> Char -> Constr mkCharConstr dt c = case datarep dt of CharRep -> mkPrimCon dt (show c) (CharConstr c) - _ -> error $ "Data.Data.mkCharConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.mkCharConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an Char data type." @@ -856,7 +856,7 @@ instance Data Bool where gunfold _ z c = case constrIndex c of 1 -> z False 2 -> z True - _ -> error $ "Data.Data.gunfold: Constructor " + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Bool." dataTypeOf _ = boolDataType @@ -871,7 +871,7 @@ instance Data Char where toConstr x = mkCharConstr charType x gunfold _ z c = case constrRep c of (CharConstr x) -> z x - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Char." dataTypeOf _ = charType @@ -885,7 +885,7 @@ instance Data Float where toConstr = mkRealConstr floatType gunfold _ z c = case constrRep c of (FloatConstr x) -> z (realToFrac x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Float." dataTypeOf _ = floatType @@ -899,7 +899,7 @@ instance Data Double where toConstr = mkRealConstr doubleType gunfold _ z c = case constrRep c of (FloatConstr x) -> z (realToFrac x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Double." dataTypeOf _ = doubleType @@ -913,7 +913,7 @@ instance Data Int where toConstr x = mkIntegralConstr intType x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int." dataTypeOf _ = intType @@ -927,7 +927,7 @@ instance Data Integer where toConstr = mkIntegralConstr integerType gunfold _ z c = case constrRep c of (IntConstr x) -> z x - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Integer." dataTypeOf _ = integerType @@ -941,7 +941,7 @@ instance Data Int8 where toConstr x = mkIntegralConstr int8Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int8." dataTypeOf _ = int8Type @@ -955,7 +955,7 @@ instance Data Int16 where toConstr x = mkIntegralConstr int16Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int16." dataTypeOf _ = int16Type @@ -969,7 +969,7 @@ instance Data Int32 where toConstr x = mkIntegralConstr int32Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int32." dataTypeOf _ = int32Type @@ -983,7 +983,7 @@ instance Data Int64 where toConstr x = mkIntegralConstr int64Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int64." dataTypeOf _ = int64Type @@ -997,7 +997,7 @@ instance Data Word where toConstr x = mkIntegralConstr wordType x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word" dataTypeOf _ = wordType @@ -1011,7 +1011,7 @@ instance Data Word8 where toConstr x = mkIntegralConstr word8Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word8." dataTypeOf _ = word8Type @@ -1025,7 +1025,7 @@ instance Data Word16 where toConstr x = mkIntegralConstr word16Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word16." dataTypeOf _ = word16Type @@ -1039,7 +1039,7 @@ instance Data Word32 where toConstr x = mkIntegralConstr word32Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word32." dataTypeOf _ = word32Type @@ -1053,7 +1053,7 @@ instance Data Word64 where toConstr x = mkIntegralConstr word64Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word64." dataTypeOf _ = word64Type @@ -1070,7 +1070,7 @@ instance (Data a, Integral a) => Data (Ratio a) where gfoldl k z (a :% b) = z (%) `k` a `k` b toConstr _ = ratioConstr gunfold k z c | constrIndex c == 1 = k (k (z (%))) - gunfold _ _ _ = error "Data.Data.gunfold(Ratio)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(Ratio)" dataTypeOf _ = ratioDataType @@ -1092,7 +1092,7 @@ instance Data a => Data [a] where gunfold k z c = case constrIndex c of 1 -> z [] 2 -> k (k (z (:))) - _ -> error "Data.Data.gunfold(List)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(List)" dataTypeOf _ = listDataType dataCast1 f = gcast1 f @@ -1126,7 +1126,7 @@ instance Data a => Data (Maybe a) where gunfold k z c = case constrIndex c of 1 -> z Nothing 2 -> k (z Just) - _ -> error "Data.Data.gunfold(Maybe)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Maybe)" dataTypeOf _ = maybeDataType dataCast1 f = gcast1 f @@ -1154,7 +1154,7 @@ instance Data Ordering where 1 -> z LT 2 -> z EQ 3 -> z GT - _ -> error "Data.Data.gunfold(Ordering)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Ordering)" dataTypeOf _ = orderingDataType @@ -1177,7 +1177,7 @@ instance (Data a, Data b) => Data (Either a b) where gunfold k z c = case constrIndex c of 1 -> k (z Left) 2 -> k (z Right) - _ -> error "Data.Data.gunfold(Either)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Either)" dataTypeOf _ = eitherDataType dataCast2 f = gcast2 f @@ -1193,7 +1193,7 @@ tuple0DataType = mkDataType "Prelude.()" [tuple0Constr] instance Data () where toConstr () = tuple0Constr gunfold _ z c | constrIndex c == 1 = z () - gunfold _ _ _ = error "Data.Data.gunfold(unit)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(unit)" dataTypeOf _ = tuple0DataType @@ -1209,7 +1209,7 @@ instance (Data a, Data b) => Data (a,b) where gfoldl f z (a,b) = z (,) `f` a `f` b toConstr (_,_) = tuple2Constr gunfold k z c | constrIndex c == 1 = k (k (z (,))) - gunfold _ _ _ = error "Data.Data.gunfold(tup2)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(tup2)" dataTypeOf _ = tuple2DataType dataCast2 f = gcast2 f @@ -1226,7 +1226,7 @@ instance (Data a, Data b, Data c) => Data (a,b,c) where gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c toConstr (_,_,_) = tuple3Constr gunfold k z c | constrIndex c == 1 = k (k (k (z (,,)))) - gunfold _ _ _ = error "Data.Data.gunfold(tup3)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(tup3)" dataTypeOf _ = tuple3DataType @@ -1244,7 +1244,7 @@ instance (Data a, Data b, Data c, Data d) toConstr (_,_,_,_) = tuple4Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (z (,,,))))) - _ -> error "Data.Data.gunfold(tup4)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup4)" dataTypeOf _ = tuple4DataType @@ -1262,7 +1262,7 @@ instance (Data a, Data b, Data c, Data d, Data e) toConstr (_,_,_,_,_) = tuple5Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (z (,,,,)))))) - _ -> error "Data.Data.gunfold(tup5)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup5)" dataTypeOf _ = tuple5DataType @@ -1280,7 +1280,7 @@ instance (Data a, Data b, Data c, Data d, Data e, Data f) toConstr (_,_,_,_,_,_) = tuple6Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (k (z (,,,,,))))))) - _ -> error "Data.Data.gunfold(tup6)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup6)" dataTypeOf _ = tuple6DataType @@ -1299,23 +1299,23 @@ instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g) toConstr (_,_,_,_,_,_,_) = tuple7Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (k (k (z (,,,,,,)))))))) - _ -> error "Data.Data.gunfold(tup7)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup7)" dataTypeOf _ = tuple7DataType ------------------------------------------------------------------------------ instance Data a => Data (Ptr a) where - toConstr _ = error "Data.Data.toConstr(Ptr)" - gunfold _ _ = error "Data.Data.gunfold(Ptr)" + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(Ptr)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(Ptr)" dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr" dataCast1 x = gcast1 x ------------------------------------------------------------------------------ instance Data a => Data (ForeignPtr a) where - toConstr _ = error "Data.Data.toConstr(ForeignPtr)" - gunfold _ _ = error "Data.Data.gunfold(ForeignPtr)" + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(ForeignPtr)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(ForeignPtr)" dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr" dataCast1 x = gcast1 x @@ -1325,8 +1325,8 @@ instance Data a => Data (ForeignPtr a) where instance (Data a, Data b, Ix a) => Data (Array a b) where gfoldl f z a = z (listArray (bounds a)) `f` (elems a) - toConstr _ = error "Data.Data.toConstr(Array)" - gunfold _ _ = error "Data.Data.gunfold(Array)" + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(Array)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(Array)" dataTypeOf _ = mkNoRepType "Data.Array.Array" dataCast2 x = gcast2 x @@ -1344,7 +1344,7 @@ instance (Data t) => Data (Proxy t) where toConstr Proxy = proxyConstr gunfold _ z c = case constrIndex c of 1 -> z Proxy - _ -> error "Data.Data.gunfold(Proxy)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Proxy)" dataTypeOf _ = proxyDataType dataCast1 f = gcast1 f @@ -1362,7 +1362,7 @@ instance (a ~ b, Data a) => Data (a :~: b) where toConstr Refl = reflConstr gunfold _ z c = case constrIndex c of 1 -> z Refl - _ -> error "Data.Data.gunfold(:~:)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(:~:)" dataTypeOf _ = equalityDataType dataCast2 f = gcast2 f @@ -1380,7 +1380,7 @@ instance (Coercible a b, Data a, Data b) => Data (Coercion a b) where toConstr Coercion = coercionConstr gunfold _ z c = case constrIndex c of 1 -> z Coercion - _ -> error "Data.Data.gunfold(Coercion)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Coercion)" dataTypeOf _ = coercionDataType dataCast2 f = gcast2 f @@ -1398,7 +1398,7 @@ instance Data Version where toConstr (Version _ _) = versionConstr gunfold k z c = case constrIndex c of 1 -> k (k (z Version)) - _ -> error "Data.Data.gunfold(Version)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Version)" dataTypeOf _ = versionDataType ----------------------------------------------------------------------- diff --git a/libraries/base/Data/Dynamic.hs b/libraries/base/Data/Dynamic.hs index e7daf4614e..55082ff3be 100644 --- a/libraries/base/Data/Dynamic.hs +++ b/libraries/base/Data/Dynamic.hs @@ -135,7 +135,7 @@ dynApply (Dynamic t1 f) (Dynamic t2 x) = dynApp :: Dynamic -> Dynamic -> Dynamic dynApp f x = case dynApply f x of Just r -> r - Nothing -> error ("Type error in dynamic application.\n" ++ + Nothing -> errorWithoutStackTrace ("Type error in dynamic application.\n" ++ "Can't apply function " ++ show f ++ " to argument " ++ show x) diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs index 24b6dd18c2..722b68f694 100644 --- a/libraries/base/Data/Foldable.hs +++ b/libraries/base/Data/Foldable.hs @@ -156,7 +156,7 @@ class Foldable t where -- -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ foldr1 :: (a -> a -> a) -> t a -> a - foldr1 f xs = fromMaybe (error "foldr1: empty structure") + foldr1 f xs = fromMaybe (errorWithoutStackTrace "foldr1: empty structure") (foldr mf Nothing xs) where mf x m = Just (case m of @@ -168,7 +168,7 @@ class Foldable t where -- -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ foldl1 :: (a -> a -> a) -> t a -> a - foldl1 f xs = fromMaybe (error "foldl1: empty structure") + foldl1 f xs = fromMaybe (errorWithoutStackTrace "foldl1: empty structure") (foldl mf Nothing xs) where mf m y = Just (case m of @@ -198,12 +198,12 @@ class Foldable t where -- | The largest element of a non-empty structure. maximum :: forall a . Ord a => t a -> a - maximum = fromMaybe (error "maximum: empty structure") . + maximum = fromMaybe (errorWithoutStackTrace "maximum: empty structure") . getMax . foldMap (Max #. (Just :: a -> Maybe a)) -- | The least element of a non-empty structure. minimum :: forall a . Ord a => t a -> a - minimum = fromMaybe (error "minimum: empty structure") . + minimum = fromMaybe (errorWithoutStackTrace "minimum: empty structure") . getMin . foldMap (Min #. (Just :: a -> Maybe a)) -- | The 'sum' function computes the sum of the numbers of a structure. @@ -276,8 +276,8 @@ instance Foldable Proxy where {-# INLINE foldr #-} foldl _ z _ = z {-# INLINE foldl #-} - foldl1 _ _ = error "foldl1: Proxy" - foldr1 _ _ = error "foldr1: Proxy" + foldl1 _ _ = errorWithoutStackTrace "foldl1: Proxy" + foldr1 _ _ = errorWithoutStackTrace "foldr1: Proxy" length _ = 0 null _ = True elem _ _ = False diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs index 155383648f..2218fc8e17 100644 --- a/libraries/base/Data/List/NonEmpty.hs +++ b/libraries/base/Data/List/NonEmpty.hs @@ -231,7 +231,7 @@ sort = lift List.sort -- Raises an error if given an empty list. fromList :: [a] -> NonEmpty a fromList (a:as) = a :| as -fromList [] = error "NonEmpty.fromList: empty list" +fromList [] = errorWithoutStackTrace "NonEmpty.fromList: empty list" -- | Convert a stream to a normal list efficiently. toList :: NonEmpty a -> [a] @@ -440,7 +440,7 @@ isPrefixOf (y:ys) (x :| xs) = (y == x) && List.isPrefixOf ys xs (!!) ~(x :| xs) n | n == 0 = x | n > 0 = xs List.!! (n - 1) - | otherwise = error "NonEmpty.!! negative argument" + | otherwise = errorWithoutStackTrace "NonEmpty.!! negative argument" -- | The 'zip' function takes two streams and returns a stream of -- corresponding pairs. diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs index 3d9a5a9f36..e81cdf7a4c 100644 --- a/libraries/base/Data/Maybe.hs +++ b/libraries/base/Data/Maybe.hs @@ -144,7 +144,7 @@ isNothing _ = False -- *** Exception: Maybe.fromJust: Nothing -- fromJust :: Maybe a -> a -fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck +fromJust Nothing = errorWithoutStackTrace "Maybe.fromJust: Nothing" -- yuck fromJust (Just x) = x -- | The 'fromMaybe' function takes a default value and and 'Maybe' diff --git a/libraries/base/Data/OldList.hs b/libraries/base/Data/OldList.hs index be894c0877..1846182c95 100644 --- a/libraries/base/Data/OldList.hs +++ b/libraries/base/Data/OldList.hs @@ -563,7 +563,7 @@ insertBy cmp x ys@(y:ys') -- and returns the greatest element of the list by the comparison function. -- The list must be finite and non-empty. maximumBy :: (a -> a -> Ordering) -> [a] -> a -maximumBy _ [] = error "List.maximumBy: empty list" +maximumBy _ [] = errorWithoutStackTrace "List.maximumBy: empty list" maximumBy cmp xs = foldl1 maxBy xs where maxBy x y = case cmp x y of @@ -574,7 +574,7 @@ maximumBy cmp xs = foldl1 maxBy xs -- and returns the least element of the list by the comparison function. -- The list must be finite and non-empty. minimumBy :: (a -> a -> Ordering) -> [a] -> a -minimumBy _ [] = error "List.minimumBy: empty list" +minimumBy _ [] = errorWithoutStackTrace "List.minimumBy: empty list" minimumBy cmp xs = foldl1 minBy xs where minBy x y = case cmp x y of @@ -629,8 +629,8 @@ genericIndex :: (Integral i) => [a] -> i -> a genericIndex (x:_) 0 = x genericIndex (_:xs) n | n > 0 = genericIndex xs (n-1) - | otherwise = error "List.genericIndex: negative argument." -genericIndex _ _ = error "List.genericIndex: index too large." + | otherwise = errorWithoutStackTrace "List.genericIndex: negative argument." +genericIndex _ _ = errorWithoutStackTrace "List.genericIndex: index too large." -- | The 'genericReplicate' function is an overloaded version of 'replicate', -- which accepts any 'Integral' value as the number of repetitions to make. diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs index 2dad8e4e78..9f602ea0c8 100644 --- a/libraries/base/Data/Proxy.hs +++ b/libraries/base/Data/Proxy.hs @@ -52,11 +52,11 @@ instance Read (Proxy s) where readsPrec d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) instance Enum (Proxy s) where - succ _ = error "Proxy.succ" - pred _ = error "Proxy.pred" + succ _ = errorWithoutStackTrace "Proxy.succ" + pred _ = errorWithoutStackTrace "Proxy.pred" fromEnum _ = 0 toEnum 0 = Proxy - toEnum _ = error "Proxy.toEnum: 0 expected" + toEnum _ = errorWithoutStackTrace "Proxy.toEnum: 0 expected" enumFrom _ = [Proxy] enumFromThen _ _ = [Proxy] enumFromThenTo _ _ _ = [Proxy] diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs index 0cd556d6fc..6fa0cd85d6 100644 --- a/libraries/base/Data/Semigroup.hs +++ b/libraries/base/Data/Semigroup.hs @@ -125,7 +125,7 @@ class Semigroup a where -- respectively. stimes :: Integral b => b -> a -> a stimes y0 x0 - | y0 <= 0 = error "stimes: positive multiplier expected" + | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" | otherwise = f x0 y0 where f x y @@ -154,7 +154,7 @@ instance Semigroup b => Semigroup (a -> b) where instance Semigroup [a] where (<>) = (++) stimes n x - | n < 0 = error "stimes: [], negative multiplier" + | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier" | otherwise = rep n where rep 0 = [] @@ -166,7 +166,7 @@ instance Semigroup a => Semigroup (Maybe a) where Just a <> Just b = Just (a <> b) stimes _ Nothing = Nothing stimes n (Just a) = case compare n 0 of - LT -> error "stimes: Maybe, negative multiplier" + LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" EQ -> Nothing GT -> Just (stimes n a) @@ -231,7 +231,7 @@ instance Num a => Semigroup (Product a) where -- and so it should be preferred where possible. stimesMonoid :: (Integral b, Monoid a) => b -> a -> a stimesMonoid n x0 = case compare n 0 of - LT -> error "stimesMonoid: negative multiplier" + LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" EQ -> mempty GT -> f x0 n where @@ -250,7 +250,7 @@ stimesMonoid n x0 = case compare n 0 of -- works in /O(1)/ rather than /O(log n)/ stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a stimesIdempotentMonoid n x = case compare n 0 of - LT -> error "stimesIdempotentMonoid: negative multiplier" + LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" EQ -> mempty GT -> x @@ -260,7 +260,7 @@ stimesIdempotentMonoid n x = case compare n 0 of -- works in /O(1)/ rather than /O(log n)/. stimesIdempotent :: Integral b => b -> a -> a stimesIdempotent n x - | n <= 0 = error "stimesIdempotent: positive multiplier expected" + | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" | otherwise = x instance Semigroup a => Semigroup (Const a b) where @@ -616,7 +616,7 @@ instance Semigroup a => Semigroup (Option a) where stimes _ (Option Nothing) = Option Nothing stimes n (Option (Just a)) = case compare n 0 of - LT -> error "stimes: Option, negative multiplier" + LT -> errorWithoutStackTrace "stimes: Option, negative multiplier" EQ -> Option Nothing GT -> Option (Just (stimes n a)) diff --git a/libraries/base/Data/Type/Coercion.hs b/libraries/base/Data/Type/Coercion.hs index c85af5b282..cc34683f62 100644 --- a/libraries/base/Data/Type/Coercion.hs +++ b/libraries/base/Data/Type/Coercion.hs @@ -77,7 +77,7 @@ instance Coercible a b => Read (Coercion a b) where instance Coercible a b => Enum (Coercion a b) where toEnum 0 = Coercion - toEnum _ = error "Data.Type.Coercion.toEnum: bad argument" + toEnum _ = errorWithoutStackTrace "Data.Type.Coercion.toEnum: bad argument" fromEnum Coercion = 0 diff --git a/libraries/base/Data/Type/Equality.hs b/libraries/base/Data/Type/Equality.hs index 027a80092b..a72e268a71 100644 --- a/libraries/base/Data/Type/Equality.hs +++ b/libraries/base/Data/Type/Equality.hs @@ -122,7 +122,7 @@ instance a ~ b => Read (a :~: b) where instance a ~ b => Enum (a :~: b) where toEnum 0 = Refl - toEnum _ = error "Data.Type.Equality.toEnum: bad argument" + toEnum _ = errorWithoutStackTrace "Data.Type.Equality.toEnum: bad argument" fromEnum Refl = 0 diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs index 6b3a923dbc..c736f56c66 100644 --- a/libraries/base/GHC/Arr.hs +++ b/libraries/base/GHC/Arr.hs @@ -173,13 +173,13 @@ can do better, so we override the default method for index. {-# NOINLINE indexError #-} indexError :: Show a => (a,a) -> a -> String -> b indexError rng i tp - = error (showString "Ix{" . showString tp . showString "}.index: Index " . + = errorWithoutStackTrace (showString "Ix{" . showString tp . showString "}.index: Index " . showParen True (showsPrec 0 i) . showString " out of range " $ showParen True (showsPrec 0 rng) "") hopelessIndexError :: Int -- Try to use 'indexError' instead! -hopelessIndexError = error "Error in array index" +hopelessIndexError = errorWithoutStackTrace "Error in array index" ---------------------------------------------------------------------- instance Ix Char where @@ -399,7 +399,7 @@ instance Eq (STArray s i e) where {-# NOINLINE arrEleBottom #-} arrEleBottom :: a -arrEleBottom = error "(Array.!): undefined array element" +arrEleBottom = errorWithoutStackTrace "(Array.!): undefined array element" -- | Construct an array with the specified bounds and containing values -- for given indices within these bounds. @@ -504,7 +504,7 @@ safeRangeSize (l,u) = let r = rangeSize (l, u) -- Don't inline this error message everywhere!! negRange :: Int -- Uninformative, but Ix does not provide Show -negRange = error "Negative range size" +negRange = errorWithoutStackTrace "Negative range size" {-# INLINE[1] safeIndex #-} -- See Note [Double bounds-checking of index values] @@ -531,7 +531,7 @@ lessSafeIndex (l,u) _ i = index (l,u) i -- Don't inline this long error message everywhere!! badSafeIndex :: Int -> Int -> Int -badSafeIndex i' n = error ("Error in array index; " ++ show i' ++ +badSafeIndex i' n = errorWithoutStackTrace ("Error in array index; " ++ show i' ++ " not in range [0.." ++ show n ++ ")") {-# INLINE unsafeAt #-} @@ -604,7 +604,7 @@ foldl1Elems f = \ arr@(Array _ _ n _) -> go i | i == 0 = unsafeAt arr 0 | otherwise = f (go (i-1)) (unsafeAt arr i) in - if n == 0 then error "foldl1: empty Array" else go (n-1) + if n == 0 then errorWithoutStackTrace "foldl1: empty Array" else go (n-1) -- | A right fold over the elements with no starting value {-# INLINABLE foldr1Elems #-} @@ -614,7 +614,7 @@ foldr1Elems f = \ arr@(Array _ _ n _) -> go i | i == n-1 = unsafeAt arr i | otherwise = f (unsafeAt arr i) (go (i + 1)) in - if n == 0 then error "foldr1: empty Array" else go 0 + if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0 -- | The list of associations of an array in index order. {-# INLINE assocs #-} diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 89ec703163..92a1ac39f7 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -187,8 +187,8 @@ not True = False (&&) True True = True otherwise = True -build = error "urk" -foldr = error "urk" +build = errorWithoutStackTrace "urk" +foldr = errorWithoutStackTrace "urk" #endif -- | The 'Maybe' type encapsulates an optional value. A value of type @@ -498,7 +498,7 @@ class Applicative m => Monad m where -- details). The definition here will be removed in a future -- release. fail :: String -> m a - fail s = error s + fail s = errorWithoutStackTrace s {- Note [Recursive bindings for Applicative/Monad] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/libraries/base/GHC/Char.hs b/libraries/base/GHC/Char.hs index 4928f21e96..c2f4ec4fe5 100644 --- a/libraries/base/GHC/Char.hs +++ b/libraries/base/GHC/Char.hs @@ -11,5 +11,5 @@ chr :: Int -> Char chr i@(I# i#) | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = C# (chr# i#) | otherwise - = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "") + = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "") diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs index b2c96b9fdb..1e9ffd58f0 100644 --- a/libraries/base/GHC/Conc/IO.hs +++ b/libraries/base/GHC/Conc/IO.hs @@ -198,6 +198,6 @@ registerDelay usecs #else | threaded = Event.registerDelay usecs #endif - | otherwise = error "registerDelay: requires -threaded" + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool diff --git a/libraries/base/GHC/Conc/Signal.hs b/libraries/base/GHC/Conc/Signal.hs index 4afccf2496..e5cb5e3e43 100644 --- a/libraries/base/GHC/Conc/Signal.hs +++ b/libraries/base/GHC/Conc/Signal.hs @@ -55,7 +55,7 @@ setHandler sig handler = do let int = fromIntegral sig withMVar signal_handlers $ \arr -> if not (inRange (boundsIOArray arr) int) - then error "GHC.Conc.setHandler: signal out of range" + then errorWithoutStackTrace "GHC.Conc.setHandler: signal out of range" else do old <- unsafeReadIOArray arr int unsafeWriteIOArray arr int handler return old diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index 5e277332d0..e1d894a8c1 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -766,7 +766,7 @@ alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) -- False or raising an exception are both treated as invariant failures. always :: STM Bool -> STM () always i = alwaysSucceeds ( do v <- i - if (v) then return () else ( error "Transactional invariant violation" ) ) + if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) ) -- |Shared memory locations that support atomic memory transactions. data TVar a = TVar (TVar# RealWorld a) diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs index 8913a65907..4cbb8cadc2 100644 --- a/libraries/base/GHC/Conc/Windows.hs +++ b/libraries/base/GHC/Conc/Windows.hs @@ -123,7 +123,7 @@ threadDelay time registerDelay :: Int -> IO (TVar Bool) registerDelay usecs | threaded = waitForDelayEventSTM usecs - | otherwise = error "registerDelay: requires -threaded" + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool @@ -299,7 +299,7 @@ toWin32ConsoleEvent ev = _ -> Nothing win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) -win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler")) +win32ConsoleHandler = unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler")) wakeupIOManager :: IO () wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP diff --git a/libraries/base/GHC/ConsoleHandler.hs b/libraries/base/GHC/ConsoleHandler.hs index 609eb2005c..6d1e36f4ab 100644 --- a/libraries/base/GHC/ConsoleHandler.hs +++ b/libraries/base/GHC/ConsoleHandler.hs @@ -96,7 +96,7 @@ installHandler handler STG_SIG_DFL -> return Default STG_SIG_IGN -> return Ignore STG_SIG_HAN -> return (Catch old_h) - _ -> error "installHandler: Bad threaded rc value" + _ -> errorWithoutStackTrace "installHandler: Bad threaded rc value" return (new_h, prev_handler) | otherwise = @@ -118,7 +118,7 @@ installHandler handler -- stable pointer is no longer in use, free it. freeStablePtr osptr return (Catch (\ ev -> oldh (fromConsoleEvent ev))) - _ -> error "installHandler: Bad non-threaded rc value" + _ -> errorWithoutStackTrace "installHandler: Bad non-threaded rc value" where fromConsoleEvent ev = case ev of @@ -135,7 +135,7 @@ installHandler handler Just x -> hdlr x >> rts_ConsoleHandlerDone ev Nothing -> return () -- silently ignore.. - no_handler = error "win32ConsoleHandler" + no_handler = errorWithoutStackTrace "win32ConsoleHandler" foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs index dcda47b9fb..729b801dcf 100644 --- a/libraries/base/GHC/Enum.hs +++ b/libraries/base/GHC/Enum.hs @@ -123,7 +123,7 @@ boundedEnumFromThen n1 n2 {-# NOINLINE toEnumError #-} toEnumError :: (Show a) => String -> Int -> (a,a) -> b toEnumError inst_ty i bnds = - error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++ + errorWithoutStackTrace $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++ show i ++ ") is outside of bounds " ++ show bnds @@ -131,7 +131,7 @@ toEnumError inst_ty i bnds = {-# NOINLINE fromEnumError #-} fromEnumError :: (Show a) => String -> a -> b fromEnumError inst_ty x = - error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++ + errorWithoutStackTrace $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++ show x ++ ") is outside of Int's bounds " ++ show (minBound::Int, maxBound::Int) @@ -139,12 +139,12 @@ fromEnumError inst_ty x = {-# NOINLINE succError #-} succError :: String -> a succError inst_ty = - error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound" + errorWithoutStackTrace $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound" {-# NOINLINE predError #-} predError :: String -> a predError inst_ty = - error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound" + errorWithoutStackTrace $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound" ------------------------------------------------------------------------ -- Tuples @@ -155,11 +155,11 @@ instance Bounded () where maxBound = () instance Enum () where - succ _ = error "Prelude.Enum.().succ: bad argument" - pred _ = error "Prelude.Enum.().pred: bad argument" + succ _ = errorWithoutStackTrace "Prelude.Enum.().succ: bad argument" + pred _ = errorWithoutStackTrace "Prelude.Enum.().pred: bad argument" toEnum x | x == 0 = () - | otherwise = error "Prelude.Enum.().toEnum: bad argument" + | otherwise = errorWithoutStackTrace "Prelude.Enum.().toEnum: bad argument" fromEnum () = 0 enumFrom () = [()] @@ -266,14 +266,14 @@ instance Bounded Bool where instance Enum Bool where succ False = True - succ True = error "Prelude.Enum.Bool.succ: bad argument" + succ True = errorWithoutStackTrace "Prelude.Enum.Bool.succ: bad argument" pred True = False - pred False = error "Prelude.Enum.Bool.pred: bad argument" + pred False = errorWithoutStackTrace "Prelude.Enum.Bool.pred: bad argument" toEnum n | n == 0 = False | n == 1 = True - | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument" + | otherwise = errorWithoutStackTrace "Prelude.Enum.Bool.toEnum: bad argument" fromEnum False = 0 fromEnum True = 1 @@ -293,16 +293,16 @@ instance Bounded Ordering where instance Enum Ordering where succ LT = EQ succ EQ = GT - succ GT = error "Prelude.Enum.Ordering.succ: bad argument" + succ GT = errorWithoutStackTrace "Prelude.Enum.Ordering.succ: bad argument" pred GT = EQ pred EQ = LT - pred LT = error "Prelude.Enum.Ordering.pred: bad argument" + pred LT = errorWithoutStackTrace "Prelude.Enum.Ordering.pred: bad argument" toEnum n | n == 0 = LT | n == 1 = EQ | n == 2 = GT - toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument" + toEnum _ = errorWithoutStackTrace "Prelude.Enum.Ordering.toEnum: bad argument" fromEnum LT = 0 fromEnum EQ = 1 @@ -323,10 +323,10 @@ instance Bounded Char where instance Enum Char where succ (C# c#) | isTrue# (ord# c# /=# 0x10FFFF#) = C# (chr# (ord# c# +# 1#)) - | otherwise = error ("Prelude.Enum.Char.succ: bad argument") + | otherwise = errorWithoutStackTrace ("Prelude.Enum.Char.succ: bad argument") pred (C# c#) | isTrue# (ord# c# /=# 0#) = C# (chr# (ord# c# -# 1#)) - | otherwise = error ("Prelude.Enum.Char.pred: bad argument") + | otherwise = errorWithoutStackTrace ("Prelude.Enum.Char.pred: bad argument") toEnum = chr fromEnum = ord @@ -449,10 +449,10 @@ instance Bounded Int where instance Enum Int where succ x - | x == maxBound = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound" + | x == maxBound = errorWithoutStackTrace "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound" | otherwise = x + 1 pred x - | x == minBound = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound" + | x == minBound = errorWithoutStackTrace "Prelude.Enum.pred{Int}: tried to take `pred' of minBound" | otherwise = x - 1 toEnum x = x diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index 6c40cba570..af6d119ff1 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -21,7 +21,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Err( absentErr, error, undefined ) where +module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.CString () import GHC.Types (Char) import GHC.Stack.Types @@ -35,6 +35,33 @@ import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) error :: (?callStack :: CallStack) => [Char] -> a error s = raise# (errorCallWithCallStackException s ?callStack) +-- | A variant of 'error' that does not produce a stack trace. +-- +-- @since 4.9.0.0 +errorWithoutStackTrace :: [Char] -> a +errorWithoutStackTrace s + = let ?callStack = freezeCallStack ?callStack + in error s +{-# NOINLINE errorWithoutStackTrace #-} + +-- Note [Errors in base] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- As of base-4.9.0.0, `error` produces a stack trace alongside the +-- error message using the Implicit CallStack machinery. This provides +-- a partial stack trace, containing the call-site of each function +-- with a (?callStack :: CallStack) implicit parameter constraint. +-- +-- In base, however, the only functions that have such constraints are +-- error and undefined, so the stack traces from partial functions in +-- base will never contain a call-site in user code. Instead we'll +-- usually just get the actual call to error. Base functions already +-- have a good habit of providing detailed error messages, including the +-- name of the offending partial function, so the partial stack-trace +-- does not provide any extra information, just noise. Thus, we export +-- the callstack-aware error, but within base we use the +-- errorWithoutStackTrace variant for more hygienic erorr messages. + + -- | A special case of 'error'. -- It is expected that compilers will recognize this and insert error -- messages which are more appropriate to the context in which 'undefined' @@ -45,4 +72,4 @@ undefined = error "Prelude.undefined" -- | Used for compiler-generated error message; -- encoding saves bytes of string junk. absentErr :: a -absentErr = error "Oops! The program has entered an `absent' argument!\n" +absentErr = errorWithoutStackTrace "Oops! The program has entered an `absent' argument!\n" diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs index 61cc773007..903f7c0c23 100644 --- a/libraries/base/GHC/Event/Array.hs +++ b/libraries/base/GHC/Event/Array.hs @@ -45,7 +45,7 @@ import GHC.Show (show) -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek! #define CHECK_BOUNDS(_func_,_len_,_k_) \ -if (_k_) < 0 || (_k_) >= (_len_) then error ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else +if (_k_) < 0 || (_k_) >= (_len_) then errorWithoutStackTrace ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else #else #define CHECK_BOUNDS(_func_,_len_,_k_) #endif @@ -247,7 +247,7 @@ copy' d dstart s sstart maxCount = copyHack d s undefined copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b) copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 || - sstart > slen) $ error "copy: bad offsets or lengths" + sstart > slen) $ errorWithoutStackTrace "copy: bad offsets or lengths" let size = sizeOf dummy count = min maxCount (slen - sstart) if count == 0 @@ -267,7 +267,7 @@ removeAt a i = removeHack a undefined removeHack :: Storable b => Array b -> b -> IO () removeHack (Array ary) dummy = do AC fp oldLen cap <- readIORef ary - when (i < 0 || i >= oldLen) $ error "removeAt: invalid index" + when (i < 0 || i >= oldLen) $ errorWithoutStackTrace "removeAt: invalid index" let size = sizeOf dummy newLen = oldLen - 1 when (newLen > 0 && i < newLen) . diff --git a/libraries/base/GHC/Event/Control.hs b/libraries/base/GHC/Event/Control.hs index 5dcc66e6dc..0b0f5587a7 100644 --- a/libraries/base/GHC/Event/Control.hs +++ b/libraries/base/GHC/Event/Control.hs @@ -159,7 +159,7 @@ readControlMessage ctrl fd r <- c_read (fromIntegral fd) (castPtr p_siginfo) sizeof_siginfo_t when (r /= fromIntegral sizeof_siginfo_t) $ - error "failed to read siginfo_t" + errorWithoutStackTrace "failed to read siginfo_t" let !s' = fromIntegral s return $ CMsgSignal fp s' @@ -195,7 +195,7 @@ sendMessage fd msg = alloca $ \p -> do case msg of CMsgWakeup -> poke p io_MANAGER_WAKEUP CMsgDie -> poke p io_MANAGER_DIE - CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" + CMsgSignal _fp _s -> errorWithoutStackTrace "Signals can only be sent from within the RTS" fromIntegral `fmap` c_write (fromIntegral fd) p 1 #if defined(HAVE_EVENTFD) diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc index 2cffb00931..26b6861004 100644 --- a/libraries/base/GHC/Event/EPoll.hsc +++ b/libraries/base/GHC/Event/EPoll.hsc @@ -29,7 +29,7 @@ import qualified GHC.Event.Internal as E import GHC.Base new :: IO E.Backend -new = error "EPoll back end not implemented for this platform" +new = errorWithoutStackTrace "EPoll back end not implemented for this platform" available :: Bool available = False diff --git a/libraries/base/GHC/Event/KQueue.hsc b/libraries/base/GHC/Event/KQueue.hsc index 2b8d443415..1068ec0136 100644 --- a/libraries/base/GHC/Event/KQueue.hsc +++ b/libraries/base/GHC/Event/KQueue.hsc @@ -19,7 +19,7 @@ import qualified GHC.Event.Internal as E import GHC.Base new :: IO E.Backend -new = error "KQueue back end not implemented for this platform" +new = errorWithoutStackTrace "KQueue back end not implemented for this platform" available :: Bool available = False @@ -274,7 +274,7 @@ toEvent :: Filter -> E.Event toEvent (Filter f) | f == (#const EVFILT_READ) = E.evtRead | f == (#const EVFILT_WRITE) = E.evtWrite - | otherwise = error $ "toEvent: unknown filter " ++ show f + | otherwise = errorWithoutStackTrace $ "toEvent: unknown filter " ++ show f foreign import ccall unsafe "kqueue" c_kqueue :: IO CInt diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs index 0ca02c45c4..013850b5d2 100644 --- a/libraries/base/GHC/Event/Manager.hs +++ b/libraries/base/GHC/Event/Manager.hs @@ -172,7 +172,7 @@ newDefaultBackend = EPoll.new #elif defined(HAVE_POLL) newDefaultBackend = Poll.new #else -newDefaultBackend = error "no back end for this platform" +newDefaultBackend = errorWithoutStackTrace "no back end for this platform" #endif -- | Create a new event manager. @@ -212,7 +212,7 @@ failOnInvalidFile loc fd m = do when (not ok) $ let msg = "Failed while attempting to modify registration of file " ++ show fd ++ " at location " ++ loc - in error msg + in errorWithoutStackTrace msg registerControlFd :: EventManager -> Fd -> Event -> IO () registerControlFd mgr fd evs = @@ -267,7 +267,7 @@ loop mgr@EventManager{..} = do -- in Thread.restartPollLoop. See #8235 Finished -> return () _ -> do cleanup mgr - error $ "GHC.Event.Manager.loop: state is already " ++ + errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++ show state where go = do state <- step mgr diff --git a/libraries/base/GHC/Event/PSQ.hs b/libraries/base/GHC/Event/PSQ.hs index 3421b5a984..e61c31b1b4 100644 --- a/libraries/base/GHC/Event/PSQ.hs +++ b/libraries/base/GHC/Event/PSQ.hs @@ -458,7 +458,7 @@ tourView (Winner e (LLoser _ e' tl m tr) m') = -- Utility functions moduleError :: String -> String -> a -moduleError fun msg = error ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg) +moduleError fun msg = errorWithoutStackTrace ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg) {-# NOINLINE moduleError #-} ------------------------------------------------------------------------ diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc index 6cbe14398b..b128572e71 100644 --- a/libraries/base/GHC/Event/Poll.hsc +++ b/libraries/base/GHC/Event/Poll.hsc @@ -17,7 +17,7 @@ import GHC.Base import qualified GHC.Event.Internal as E new :: IO E.Backend -new = error "Poll back end not implemented for this platform" +new = errorWithoutStackTrace "Poll back end not implemented for this platform" available :: Bool available = False @@ -62,7 +62,7 @@ modifyFd p fd oevt nevt = return True modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool -modifyFdOnce = error "modifyFdOnce not supported in Poll backend" +modifyFdOnce = errorWithoutStackTrace "modifyFdOnce not supported in Poll backend" reworkFd :: Poll -> PollFd -> IO () reworkFd p (PollFd fd npevt opevt) = do @@ -72,7 +72,7 @@ reworkFd p (PollFd fd npevt opevt) = do else do found <- A.findIndex ((== fd) . pfdFd) ary case found of - Nothing -> error "reworkFd: event not found" + Nothing -> errorWithoutStackTrace "reworkFd: event not found" Just (i,_) | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0 | otherwise -> A.removeAt ary i diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index c1ab64c7a9..93b1766f5e 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -108,7 +108,7 @@ newDefaultBackend :: IO Backend #if defined(HAVE_POLL) newDefaultBackend = Poll.new #else -newDefaultBackend = error "no back end for this platform" +newDefaultBackend = errorWithoutStackTrace "no back end for this platform" #endif -- | Create a new event manager. @@ -168,7 +168,7 @@ loop mgr = do Created -> go `finally` cleanup mgr Dying -> cleanup mgr _ -> do cleanup mgr - error $ "GHC.Event.Manager.loop: state is already " ++ + errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++ show state where go = do running <- step mgr diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index 032e650c1e..dc943e068d 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -103,8 +103,8 @@ maxTupleSize = 62 the :: Eq a => [a] -> a the (x:xs) | all (x ==) xs = x - | otherwise = error "GHC.Exts.the: non-identical elements" -the [] = error "GHC.Exts.the: empty list" + | otherwise = errorWithoutStackTrace "GHC.Exts.the: non-identical elements" +the [] = errorWithoutStackTrace "GHC.Exts.the: empty list" -- | The 'sortWith' function sorts a list of elements using the -- user supplied function to project something out of each element diff --git a/libraries/base/GHC/Fingerprint.hs b/libraries/base/GHC/Fingerprint.hs index 8a92cd0595..7b7f5c7115 100644 --- a/libraries/base/GHC/Fingerprint.hs +++ b/libraries/base/GHC/Fingerprint.hs @@ -95,7 +95,7 @@ getFileHash path = withBinaryFile path ReadMode $ \h -> do let loop = do count <- hGetBuf h arrPtr _BUFSIZE eof <- hIsEOF h - when (count /= _BUFSIZE && not eof) $ error $ + when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $ "GHC.Fingerprint.getFileHash: only read " ++ show count ++ " bytes" f arrPtr count diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index ddf9cf01ca..0ffefd5f67 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -658,7 +658,7 @@ formatRealFloatAlt fmt decs alt x "0" -> "0.0e0" [d] -> d : ".0e" ++ show_e' (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' - [] -> error "formatRealFloat/doFmt/FFExponent: []" + [] -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []" Just dec -> let dec' = max dec 1 in case is of @@ -704,7 +704,7 @@ roundTo base d is = case f d True is of x@(0,_) -> x (1,xs) -> (1, 1:xs) - _ -> error "roundTo: bad Value" + _ -> errorWithoutStackTrace "roundTo: bad Value" where b2 = base `quot` 2 diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index d0688f0cbf..6d03967d3b 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -153,7 +153,7 @@ mallocForeignPtr :: Storable a => IO (ForeignPtr a) mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc a - | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0" | otherwise = do r <- newIORef NoFinalizers IO $ \s -> @@ -168,7 +168,7 @@ mallocForeignPtr = doMalloc undefined -- size of the memory required is given explicitly as a number of bytes. mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) mallocForeignPtrBytes size | size < 0 = - error "mallocForeignPtrBytes: size must be >= 0" + errorWithoutStackTrace "mallocForeignPtrBytes: size must be >= 0" mallocForeignPtrBytes (I# size) = do r <- newIORef NoFinalizers IO $ \s -> @@ -182,7 +182,7 @@ mallocForeignPtrBytes (I# size) = do -- bytes. mallocForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a) mallocForeignPtrAlignedBytes size _align | size < 0 = - error "mallocForeignPtrAlignedBytes: size must be >= 0" + errorWithoutStackTrace "mallocForeignPtrAlignedBytes: size must be >= 0" mallocForeignPtrAlignedBytes (I# size) (I# align) = do r <- newIORef NoFinalizers IO $ \s -> @@ -208,7 +208,7 @@ mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a) mallocPlainForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc a - | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0" | otherwise = IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -223,7 +223,7 @@ mallocPlainForeignPtr = doMalloc undefined -- exception to be thrown. mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a) mallocPlainForeignPtrBytes size | size < 0 = - error "mallocPlainForeignPtrBytes: size must be >= 0" + errorWithoutStackTrace "mallocPlainForeignPtrBytes: size must be >= 0" mallocPlainForeignPtrBytes (I# size) = IO $ \s -> case newPinnedByteArray# size s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -236,7 +236,7 @@ mallocPlainForeignPtrBytes (I# size) = IO $ \s -> -- exception to be thrown. mallocPlainForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a) mallocPlainForeignPtrAlignedBytes size _align | size < 0 = - error "mallocPlainForeignPtrAlignedBytes: size must be >= 0" + errorWithoutStackTrace "mallocPlainForeignPtrAlignedBytes: size must be >= 0" mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -250,7 +250,7 @@ addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO () addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of PlainForeignPtr r -> insertCFinalizer r fp 0# nullAddr# p () MallocPtr _ r -> insertCFinalizer r fp 0# nullAddr# p c - _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" -- Note [MallocPtr finalizers] (#10904) -- @@ -270,7 +270,7 @@ addForeignPtrFinalizerEnv :: addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of PlainForeignPtr r -> insertCFinalizer r fp 1# ep p () MallocPtr _ r -> insertCFinalizer r fp 1# ep p c - _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO () -- ^This function adds a finalizer to the given @ForeignPtr@. The @@ -311,7 +311,7 @@ addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do finalizer' = unIO (foreignPtrFinalizer r >> touch f) addForeignPtrConcFinalizer_ _ _ = - error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer" + errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to plain pointer" insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool insertHaskellFinalizer r f = do @@ -358,7 +358,7 @@ ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do update _ _ = noMixingError noMixingError :: a -noMixingError = error $ +noMixingError = errorWithoutStackTrace $ "GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++ "in the same ForeignPtr" @@ -441,5 +441,5 @@ finalizeForeignPtr (ForeignPtr _ foreignPtr) = foreignPtrFinalizer refFinalizers (PlainForeignPtr ref) -> ref (MallocPtr _ ref) -> ref PlainPtr _ -> - error "finalizeForeignPtr PlainPtr" + errorWithoutStackTrace "finalizeForeignPtr PlainPtr" diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs index 77f1d99f46..b2d4cd1843 100644 --- a/libraries/base/GHC/IO/Buffer.hs +++ b/libraries/base/GHC/IO/Buffer.hs @@ -287,5 +287,5 @@ checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do check :: Buffer a -> Bool -> IO () check _ True = return () -check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf) +check buf False = errorWithoutStackTrace ("buffer invariant violation: " ++ summaryBuffer buf) diff --git a/libraries/base/GHC/IO/Encoding/CodePage/API.hs b/libraries/base/GHC/IO/Encoding/CodePage/API.hs index 103eb87a0d..5a48a9ee3d 100644 --- a/libraries/base/GHC/IO/Encoding/CodePage/API.hs +++ b/libraries/base/GHC/IO/Encoding/CodePage/API.hs @@ -83,7 +83,7 @@ instance Storable CPINFO where pokeArray' :: Storable a => String -> Int -> Ptr a -> [a] -> IO () pokeArray' msg sz ptr xs | length xs == sz = pokeArray ptr xs - | otherwise = error $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs) + | otherwise = errorWithoutStackTrace $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs) foreign import WINDOWS_CCONV unsafe "windows.h GetCPInfo" @@ -189,7 +189,7 @@ byteView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr b cwcharView :: Buffer Word8 -> Buffer CWchar cwcharView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = half bufSize, bufL = half bufL, bufR = half bufR } where half x = case x `divMod` 2 of (y, 0) -> y - _ -> error "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes" + _ -> errorWithoutStackTrace "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes" utf16_native_encode :: CodeBuffer Char CWchar utf16_native_encode ibuf obuf = do @@ -227,9 +227,9 @@ cpDecode cp max_char_size = \ibuf obuf -> do -- If we successfully translate all of the UTF-16 buffer, we need to know why we couldn't get any more -- UTF-16 out of the Windows API InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf) - | otherwise -> error "cpDecode: impossible underflown UTF-16 buffer" + | otherwise -> errorWithoutStackTrace "cpDecode: impossible underflown UTF-16 buffer" -- InvalidSequence should be impossible since mbuf' is output from Windows. - InvalidSequence -> error "InvalidSequence on output of Windows API" + InvalidSequence -> errorWithoutStackTrace "InvalidSequence on output of Windows API" -- If we run out of space in obuf, we need to ask for more output buffer space, while also returning -- the characters we have managed to consume so far. OutputUnderflow -> do @@ -287,7 +287,7 @@ cpEncode cp _max_char_size = \ibuf obuf -> do -- If we succesfully translate all of the UTF-16 buffer, we need to know why -- we weren't able to get any more UTF-16 out of the UTF-32 buffer InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf) - | otherwise -> error "cpEncode: impossible underflown UTF-16 buffer" + | otherwise -> errorWithoutStackTrace "cpEncode: impossible underflown UTF-16 buffer" -- With OutputUnderflow/InvalidSequence we only care about the failings of the UTF-16->CP translation. -- Yes, InvalidSequence is possible even though mbuf' is guaranteed to be valid UTF-16, because -- the code page may not be able to represent the encoded Unicode codepoint. @@ -371,7 +371,7 @@ bSearch msg code ibuf mbuf target_to_elems = go LT -> go' (md+1) mx GT -> go' mn (md-1) go' mn mx | mn <= mx = go mn (mn + ((mx - mn) `div` 2)) mx - | otherwise = error $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx) + | otherwise = errorWithoutStackTrace $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx) cpRecode :: forall from to. Storable from => (Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int)) diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs index c1d15a93b7..ca5336955c 100644 --- a/libraries/base/GHC/IO/Handle.hs +++ b/libraries/base/GHC/IO/Handle.hs @@ -255,7 +255,7 @@ hSetEncoding hdl encoding = do closeTextCodecs h_ openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do bbuf <- readIORef haByteBuffer - ref <- newIORef (error "last_decode") + ref <- newIORef (errorWithoutStackTrace "last_decode") return (Handle__{ haLastDecode = ref, haDecoder = mb_decoder, haEncoder = mb_encoder, @@ -571,7 +571,7 @@ hSetBinaryMode handle bin = | otherwise = nativeNewlineMode bbuf <- readIORef haByteBuffer - ref <- newIORef (error "codec_state", bbuf) + ref <- newIORef (errorWithoutStackTrace "codec_state", bbuf) return Handle__{ haLastDecode = ref, haEncoder = mb_encoder, diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs index 5d8ddfd981..48ece1dc5e 100644 --- a/libraries/base/GHC/IO/Handle/Internals.hs +++ b/libraries/base/GHC/IO/Handle/Internals.hs @@ -628,7 +628,7 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do let buf_state = initBufferState ha_type bbuf <- Buffered.newBuffer dev buf_state bbufref <- newIORef bbuf - last_decode <- newIORef (error "codec_state", bbuf) + last_decode <- newIORef (errorWithoutStackTrace "codec_state", bbuf) (cbufref,bmode) <- if buffered then getCharBuffer dev buf_state @@ -848,7 +848,7 @@ readTextDevice h_@Handle__{..} cbuf = do (bbuf2,cbuf') <- case haDecoder of Nothing -> do - writeIORef haLastDecode (error "codec_state", bbuf1) + writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf1) latin1_decode bbuf1 cbuf Just decoder -> do state <- getState decoder @@ -937,7 +937,7 @@ decodeByteBuf h_@Handle__{..} cbuf = do (bbuf2,cbuf') <- case haDecoder of Nothing -> do - writeIORef haLastDecode (error "codec_state", bbuf0) + writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf0) latin1_decode bbuf0 cbuf Just decoder -> do state <- getState decoder diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs index c31ab70a4a..65832c79ec 100644 --- a/libraries/base/GHC/IO/Handle/Text.hs +++ b/libraries/base/GHC/IO/Handle/Text.hs @@ -564,7 +564,7 @@ getSpareBuffer Handle__{haCharBuffer=ref, haBufferMode=mode} = do case mode of - NoBuffering -> return (mode, error "no buffer!") + NoBuffering -> return (mode, errorWithoutStackTrace "no buffer!") _ -> do bufs <- readIORef spare_ref buf <- readIORef ref diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs index 195054a7aa..b7de4ab95b 100644 --- a/libraries/base/GHC/IO/Handle/Types.hs +++ b/libraries/base/GHC/IO/Handle/Types.hs @@ -185,10 +185,10 @@ checkHandleInvariants h_ = do cbuf <- readIORef (haCharBuffer h_) checkBuffer cbuf when (isWriteBuffer cbuf && not (isEmptyBuffer cbuf)) $ - error ("checkHandleInvariants: char write buffer non-empty: " ++ + errorWithoutStackTrace ("checkHandleInvariants: char write buffer non-empty: " ++ summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf) when (isWriteBuffer bbuf /= isWriteBuffer cbuf) $ - error ("checkHandleInvariants: buffer modes differ: " ++ + errorWithoutStackTrace ("checkHandleInvariants: buffer modes differ: " ++ summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf) #else diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs index bbaa0a2751..92ded0d413 100644 --- a/libraries/base/GHC/List.hs +++ b/libraries/base/GHC/List.hs @@ -841,8 +841,8 @@ concat = foldr (++) [] -- which takes an index of any integral type. (!!) :: [a] -> Int -> a #ifdef USE_REPORT_PRELUDE -xs !! n | n < 0 = error "Prelude.!!: negative index" -[] !! _ = error "Prelude.!!: index too large" +xs !! n | n < 0 = errorWithoutStackTrace "Prelude.!!: negative index" +[] !! _ = errorWithoutStackTrace "Prelude.!!: index too large" (x:_) !! 0 = x (_:xs) !! n = xs !! (n-1) #else @@ -852,10 +852,10 @@ xs !! n | n < 0 = error "Prelude.!!: negative index" -- if so we should be careful not to trip up known-bottom -- optimizations. tooLarge :: Int -> a -tooLarge _ = error (prel_list_str ++ "!!: index too large") +tooLarge _ = errorWithoutStackTrace (prel_list_str ++ "!!: index too large") negIndex :: a -negIndex = error $ prel_list_str ++ "!!: negative index" +negIndex = errorWithoutStackTrace $ prel_list_str ++ "!!: negative index" {-# INLINABLE (!!) #-} xs !! n @@ -996,7 +996,7 @@ unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) errorEmptyList :: String -> a errorEmptyList fun = - error (prel_list_str ++ fun ++ ": empty list") + errorWithoutStackTrace (prel_list_str ++ fun ++ ": empty list") prel_list_str :: String prel_list_str = "Prelude." diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index dedf4f8790..e756f0d07f 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -215,7 +215,7 @@ instance Enum Natural where fromEnum (NatS# w) | i >= 0 = i where i = fromIntegral (W# w) - fromEnum _ = error "fromEnum: out of Int range" + fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range" enumFrom x = enumDeltaNatural x (NatS# 1##) enumFromThen x y @@ -304,10 +304,10 @@ instance Bits Natural where NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m)) NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m) - complement _ = error "Bits.complement: Natural complement undefined" + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" bitSizeMaybe _ = Nothing - bitSize = error "Natural: bitSize" + bitSize = errorWithoutStackTrace "Natural: bitSize" isSigned _ = False bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i) @@ -484,7 +484,7 @@ instance Bits Natural where {-# INLINE (.|.) #-} xor (Natural n) (Natural m) = Natural (xor n m) {-# INLINE xor #-} - complement _ = error "Bits.complement: Natural complement undefined" + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" {-# INLINE complement #-} shift (Natural n) = Natural . shift n {-# INLINE shift #-} @@ -502,7 +502,7 @@ instance Bits Natural where {-# INLINE testBit #-} bitSizeMaybe _ = Nothing {-# INLINE bitSizeMaybe #-} - bitSize = error "Natural: bitSize" + bitSize = errorWithoutStackTrace "Natural: bitSize" {-# INLINE bitSize #-} isSigned _ = False {-# INLINE isSigned #-} @@ -523,14 +523,14 @@ instance Real Natural where {-# INLINE toRational #-} instance Enum Natural where - pred (Natural 0) = error "Natural.pred: 0" + pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" pred (Natural n) = Natural (pred n) {-# INLINE pred #-} succ (Natural n) = Natural (succ n) {-# INLINE succ #-} fromEnum (Natural n) = fromEnum n {-# INLINE fromEnum #-} - toEnum n | n < 0 = error "Natural.toEnum: negative" + toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" | otherwise = Natural (toEnum n) {-# INLINE toEnum #-} @@ -597,7 +597,7 @@ instance Data Natural where toConstr x = mkIntegralConstr naturalType x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Natural" dataTypeOf _ = naturalType diff --git a/libraries/base/GHC/Pack.hs b/libraries/base/GHC/Pack.hs index 95ff849f31..73334b6c98 100644 --- a/libraries/base/GHC/Pack.hs +++ b/libraries/base/GHC/Pack.hs @@ -89,7 +89,7 @@ new_ps_array size = ST $ \ s -> case (newByteArray# size s) of { (# s2#, barr# #) -> (# s2#, MutableByteArray bot bot barr# #) } where - bot = error "new_ps_array" + bot = errorWithoutStackTrace "new_ps_array" write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# -> case writeCharArray# barr# n ch s# of { s2# -> diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc index 62e720f7c0..12cead7821 100644 --- a/libraries/base/GHC/RTS/Flags.hsc +++ b/libraries/base/GHC/RTS/Flags.hsc @@ -87,7 +87,7 @@ instance Enum GiveGCStats where toEnum #{const ONELINE_GC_STATS} = OneLineGCStats toEnum #{const SUMMARY_GC_STATS} = SummaryGCStats toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats - toEnum e = error ("invalid enum for GiveGCStats: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for GiveGCStats: " ++ show e) -- | Parameters of the garbage collector. -- @@ -185,7 +185,7 @@ instance Enum DoCostCentres where toEnum #{const COST_CENTRES_VERBOSE} = CostCentresVerbose toEnum #{const COST_CENTRES_ALL} = CostCentresAll toEnum #{const COST_CENTRES_XML} = CostCentresXML - toEnum e = error ("invalid enum for DoCostCentres: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for DoCostCentres: " ++ show e) -- | Parameters pertaining to the cost-center profiler. -- @@ -228,7 +228,7 @@ instance Enum DoHeapProfile where toEnum #{const HEAP_BY_RETAINER} = HeapByRetainer toEnum #{const HEAP_BY_LDV} = HeapByLDV toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType - toEnum e = error ("invalid enum for DoHeapProfile: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for DoHeapProfile: " ++ show e) -- | Parameters of the cost-center profiler -- @@ -267,7 +267,7 @@ instance Enum DoTrace where toEnum #{const TRACE_NONE} = TraceNone toEnum #{const TRACE_EVENTLOG} = TraceEventLog toEnum #{const TRACE_STDERR} = TraceStderr - toEnum e = error ("invalid enum for DoTrace: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for DoTrace: " ++ show e) -- | Parameters pertaining to event tracing -- diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index 31381d6bd9..186be27cdf 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -205,7 +205,7 @@ class (Real a, Fractional a) => RealFrac a where -1 -> n 0 -> if even n then n else m 1 -> m - _ -> error "round default defn: Bad value" + _ -> errorWithoutStackTrace "round default defn: Bad value" ceiling x = if r > 0 then n + 1 else n where (n,r) = properFraction x @@ -476,7 +476,7 @@ odd = not . even Int -> Int -> Int #-} {-# INLINABLE [1] (^) #-} -- See Note [Inlining (^)] (^) :: (Num a, Integral b) => a -> b -> a -x0 ^ y0 | y0 < 0 = error "Negative exponent" +x0 ^ y0 | y0 < 0 = errorWithoutStackTrace "Negative exponent" | y0 == 0 = 1 | otherwise = f x0 y0 where -- f : x0 ^ y0 = x ^ y @@ -585,7 +585,7 @@ x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) {-# RULES "(^)/Rational" (^) = (^%^) #-} (^%^) :: Integral a => Rational -> a -> Rational (n :% d) ^%^ e - | e < 0 = error "Negative exponent" + | e < 0 = errorWithoutStackTrace "Negative exponent" | e == 0 = 1 :% 1 | otherwise = (n ^ e) :% (d ^ e) diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 879d666bb0..4322aff2e8 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -396,7 +396,7 @@ intToDigit :: Int -> Char intToDigit (I# i) | isTrue# (i >=# 0#) && isTrue# (i <=# 9#) = unsafeChr (ord '0' + I# i) | isTrue# (i >=# 10#) && isTrue# (i <=# 15#) = unsafeChr (ord 'a' + I# i - 10) - | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i)) + | otherwise = errorWithoutStackTrace ("Char.intToDigit: not a digit " ++ show (I# i)) showSignedInt :: Int -> Int -> ShowS showSignedInt (I# p) (I# n) r @@ -464,7 +464,7 @@ integerToString n0 cs0 (# q, r #) -> if q > 0 then q : r : jsplitb p ns else r : jsplitb p ns - jsplith _ [] = error "jsplith: []" + jsplith _ [] = errorWithoutStackTrace "jsplith: []" jsplitb :: Integer -> [Integer] -> [Integer] jsplitb _ [] = [] @@ -483,7 +483,7 @@ integerToString n0 cs0 r = fromInteger r' in if q > 0 then jhead q $ jblock r $ jprintb ns cs else jhead r $ jprintb ns cs - jprinth [] _ = error "jprinth []" + jprinth [] _ = errorWithoutStackTrace "jprinth []" jprintb :: [Integer] -> String -> String jprintb [] cs = cs diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs index d7c5c94193..727910a659 100644 --- a/libraries/base/GHC/Stack.hs +++ b/libraries/base/GHC/Stack.hs @@ -15,7 +15,7 @@ -- @since 4.5.0.0 ----------------------------------------------------------------------------- -{-# LANGUAGE MagicHash, NoImplicitPrelude #-} +{-# LANGUAGE MagicHash, NoImplicitPrelude, ImplicitParams, RankNTypes #-} module GHC.Stack ( -- * Call stacks currentCallStack, @@ -23,7 +23,8 @@ module GHC.Stack ( errorWithStackTrace, -- * Implicit parameter call stacks - CallStack, getCallStack, pushCallStack, prettyCallStack, + CallStack, emptyCallStack, freezeCallStack, getCallStack, popCallStack, + prettyCallStack, pushCallStack, withFrozenCallStack, -- * Source locations SrcLoc(..), prettySrcLoc, @@ -62,3 +63,28 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do if null stack then throwIO (ErrorCall x) else throwIO (ErrorCallWithLocation x (renderStack stack)) + + +-- | Pop the most recent call-site off the 'CallStack'. +-- +-- This function, like 'pushCallStack', has no effect on a frozen 'CallStack'. +-- +-- @since 4.9.0.0 +popCallStack :: CallStack -> CallStack +popCallStack stk = case stk of + EmptyCallStack -> errorWithoutStackTrace "popCallStack: empty stack" + PushCallStack _ stk' -> stk' + FreezeCallStack _ -> stk + + +-- | Perform some computation without adding new entries to the 'CallStack'. +-- +-- @since 4.9.0.0 +withFrozenCallStack :: (?callStack :: CallStack) + => ( (?callStack :: CallStack) => a ) + -> a +withFrozenCallStack do_this = + -- we pop the stack before freezing it to remove + -- withFrozenCallStack's call-site + let ?callStack = freezeCallStack (popCallStack ?callStack) + in do_this diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs index ebe4591e3b..a971f7c86a 100644 --- a/libraries/base/GHC/Stack/Types.hs +++ b/libraries/base/GHC/Stack/Types.hs @@ -1,4 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} +-- we hide this module from haddock to enforce GHC.Stack as the main +-- access point. ----------------------------------------------------------------------------- -- | @@ -11,14 +14,14 @@ -- Portability : non-portable (GHC Extensions) -- -- type definitions for call-stacks via implicit parameters. --- Use GHC.Exts from the base package instead of importing this +-- Use "GHC.Stack" from the base package instead of importing this -- module directly. -- ----------------------------------------------------------------------------- module GHC.Stack.Types ( -- * Implicit parameter call stacks - CallStack, getCallStack, pushCallStack, + CallStack(..), emptyCallStack, freezeCallStack, getCallStack, pushCallStack, -- * Source locations SrcLoc(..) ) where @@ -84,12 +87,26 @@ import GHC.Integer () -- ordered with the most recently called function at the head. -- -- @since 4.8.1.0 -data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] - -- ^ Get a list of stack frames with the most - -- recently called function at the head. - } +data CallStack + = EmptyCallStack + | PushCallStack ([Char], SrcLoc) CallStack + | FreezeCallStack CallStack + -- ^ Freeze the stack at the given @CallStack@, preventing any further + -- call-sites from being pushed onto it. + -- See Note [Overview of implicit CallStacks] +-- | Extract a list of call-sites from the 'CallStack'. +-- +-- The list is ordered by most recent call. +-- +-- @since 4.8.1.0 +getCallStack :: CallStack -> [([Char], SrcLoc)] +getCallStack stk = case stk of + EmptyCallStack -> [] + PushCallStack cs stk' -> cs : getCallStack stk' + FreezeCallStack stk' -> getCallStack stk' + -- Note [Definition of CallStack] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -109,10 +126,31 @@ data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] -- | Push a call-site onto the stack. -- +-- This function has no effect on a frozen 'CallStack'. +-- -- @since 4.9.0.0 pushCallStack :: ([Char], SrcLoc) -> CallStack -> CallStack -pushCallStack callSite (CallStack stk) - = CallStack (callSite : stk) +pushCallStack cs stk = case stk of + FreezeCallStack _ -> stk + _ -> PushCallStack cs stk +{-# INLINE pushCallStack #-} + + +-- | The empty 'CallStack'. +-- +-- @since 4.9.0.0 +emptyCallStack :: CallStack +emptyCallStack = EmptyCallStack +{-# INLINE emptyCallStack #-} + +-- | Freeze a call-stack, preventing any further call-sites from being appended. +-- +-- prop> pushCallStack callSite (freezeCallStack callStack) = freezeCallStack callStack +-- +-- @since 4.9.0.0 +freezeCallStack :: CallStack -> CallStack +freezeCallStack stk = FreezeCallStack stk +{-# INLINE freezeCallStack #-} -- | A single location in the source code. diff --git a/libraries/base/Numeric.hs b/libraries/base/Numeric.hs index 51be3a1698..e8b0b91eed 100644 --- a/libraries/base/Numeric.hs +++ b/libraries/base/Numeric.hs @@ -128,7 +128,7 @@ readSigned readPos = readParen False read' -- | Show /non-negative/ 'Integral' numbers in base 10. showInt :: Integral a => a -> ShowS showInt n0 cs0 - | n0 < 0 = error "Numeric.showInt: can't show negative numbers" + | n0 < 0 = errorWithoutStackTrace "Numeric.showInt: can't show negative numbers" | otherwise = go n0 cs0 where go n cs @@ -211,8 +211,8 @@ showGFloatAlt d x = showString (formatRealFloatAlt FFGeneric d True x) -- first argument, and the character representation specified by the second. showIntAtBase :: (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS showIntAtBase base toChr n0 r0 - | base <= 1 = error ("Numeric.showIntAtBase: applied to unsupported base " ++ show base) - | n0 < 0 = error ("Numeric.showIntAtBase: applied to negative number " ++ show n0) + | base <= 1 = errorWithoutStackTrace ("Numeric.showIntAtBase: applied to unsupported base " ++ show base) + | n0 < 0 = errorWithoutStackTrace ("Numeric.showIntAtBase: applied to negative number " ++ show n0) | otherwise = showIt (quotRem n0 base) r0 where showIt (n,d) r = seq c $ -- stricter than necessary diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs index fa070f3161..158cc0a8ff 100644 --- a/libraries/base/Prelude.hs +++ b/libraries/base/Prelude.hs @@ -95,7 +95,7 @@ module Prelude ( -- ** Miscellaneous functions id, const, (.), flip, ($), until, - asTypeOf, error, undefined, + asTypeOf, error, errorWithoutStackTrace, undefined, seq, ($!), -- * List operations diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc index 410e3acda2..8b6c7b6c57 100644 --- a/libraries/base/System/Environment/ExecutablePath.hsc +++ b/libraries/base/System/Environment/ExecutablePath.hsc @@ -84,7 +84,7 @@ _NSGetExecutablePath = status2 <- c__NSGetExecutablePath newBuf bufsize if status2 == 0 then peekFilePath newBuf - else error "_NSGetExecutablePath: buffer too small" + else errorWithoutStackTrace "_NSGetExecutablePath: buffer too small" foreign import ccall unsafe "stdlib.h realpath" c_realpath :: CString -> CString -> IO CString @@ -145,7 +145,7 @@ getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 go size = allocaArray (fromIntegral size) $ \ buf -> do ret <- c_GetModuleFileName nullPtr buf size case ret of - 0 -> error "getExecutablePath: GetModuleFileNameW returned an error" + 0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error" _ | ret < size -> peekFilePath buf | otherwise -> go (size * 2) @@ -166,7 +166,7 @@ getExecutablePath = -- If argc > 0 then argv[0] is guaranteed by the standard -- to be a pointer to a null-terminated string. then peek p_argv >>= peek >>= peekFilePath - else error $ "getExecutablePath: " ++ msg + else errorWithoutStackTrace $ "getExecutablePath: " ++ msg where msg = "no OS specific implementation and program name couldn't be " ++ "found in argv" diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index e0ee9b15be..04e976a85b 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -480,7 +480,7 @@ openTempFile' loc tmp_dir template binary mode = findTempName -- Otherwise, something is wrong, because (break (== '.')) should -- always return a pair with either the empty string or a string -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" + _ -> errorWithoutStackTrace "bug in System.IO.openTempFile" findTempName = do rs <- rand_string diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs index 7bdb97cebd..6c340e4597 100644 --- a/libraries/base/Text/ParserCombinators/ReadP.hs +++ b/libraries/base/Text/ParserCombinators/ReadP.hs @@ -248,7 +248,7 @@ gather (R m) gath _ Fail = Fail gath l (Look f) = Look (\s -> gath l (f s)) gath l (Result k p) = k (l []) <|> gath l p - gath _ (Final _) = error "do not use readS_to_P in gather!" + gath _ (Final _) = errorWithoutStackTrace "do not use readS_to_P in gather!" -- --------------------------------------------------------------------------- -- Derived operations diff --git a/libraries/base/Text/Printf.hs b/libraries/base/Text/Printf.hs index 2ccbc11c2f..4d12e561c7 100644 --- a/libraries/base/Text/Printf.hs +++ b/libraries/base/Text/Printf.hs @@ -871,7 +871,7 @@ dfmt c p a d = -- -- @since 4.7.0.0 perror :: String -> a -perror s = error $ "printf: " ++ s +perror s = errorWithoutStackTrace $ "printf: " ++ s -- | Calls 'perror' to indicate an unknown format letter for -- a given type. diff --git a/libraries/base/Text/Read.hs b/libraries/base/Text/Read.hs index 0e752c2bbb..2479eb529a 100644 --- a/libraries/base/Text/Read.hs +++ b/libraries/base/Text/Read.hs @@ -87,4 +87,4 @@ readMaybe s = case readEither s of -- | The 'read' function reads input from a string, which must be -- completely consumed by the input process. read :: Read a => String -> a -read s = either error id (readEither s) +read s = either errorWithoutStackTrace id (readEither s) diff --git a/libraries/base/Text/Read/Lex.hs b/libraries/base/Text/Read/Lex.hs index 608bf85de4..ed4d204c86 100644 --- a/libraries/base/Text/Read/Lex.hs +++ b/libraries/base/Text/Read/Lex.hs @@ -504,7 +504,7 @@ valInteger b0 ds0 = go b0 (length ds0) $ map fromIntegral ds0 where d = d1 * b + d2 combine _ [] = [] - combine _ [_] = error "this should not happen" + combine _ [_] = errorWithoutStackTrace "this should not happen" -- Calculate a Rational from the exponent [of 10 to multiply with], -- the integral part of the mantissa and the digits of the fractional @@ -536,7 +536,7 @@ valDig 16 c | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10) | otherwise = Nothing -valDig _ _ = error "valDig: Bad base" +valDig _ _ = errorWithoutStackTrace "valDig: Bad base" valDecDig :: Char -> Maybe Int valDecDig c diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 92685ca773..8560fe7110 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -4,17 +4,33 @@ * Bundled with GHC 8.0 + * `error` and `undefined` now print a partial stack-trace alongside the error message. + + * New `errorWithoutStackTrace` function throws an error without printing the stack trace. + * The restore operation provided by `mask` and `uninterruptibleMask` now restores the previous masking state whatever the current masking state is. - * Redundant typeclass constraints have been removed: - - `Data.Ratio.{denominator,numerator}` have no `Integral` constraint anymore - - **TODO** - * New `GHC.Generics.packageName` operation * New `GHC.Stack.CallStack` data type + * New `GHC.Generics.packageName` operation + + * New `GHC.Stack.Types` module now contains the definition of + `CallStack` and `SrcLoc` + + * New `GHC.Stack.Types.emptyCallStack` function builds an empty `CallStack` + + * New `GHC.Stack.Types.freezeCallStack` function freezes a `CallStack` preventing future `pushCallStack` operations from having any effect + + * New `GHC.Stack.Types.pushCallStack` function pushes a call-site onto a `CallStack` + + * `GHC.SrcLoc` has been removed + + * `GHC.Stack.showCallStack` and `GHC.SrcLoc.showSrcLoc` are now called + `GHC.Stack.prettyCallStack` and `GHC.Stack.prettySrcLoc` respectively + * add `Data.List.NonEmpty` and `Data.Semigroup` (to become super-class of `Monoid` in the future). These modules were provided by the `semigroups` package previously. (#10365) @@ -119,6 +135,10 @@ * Generalize `Debug.Trace.{traceM, traceShowM}` from `Monad` to `Applicative` (#10023) + * Redundant typeclass constraints have been removed: + - `Data.Ratio.{denominator,numerator}` have no `Integral` constraint anymore + - **TODO** + * Generalise `forever` from `Monad` to `Applicative` * Generalize `filterM`, `mapAndUnzipM`, `zipWithM`, `zipWithM_`, `replicateM`, diff --git a/libraries/base/codepages/MakeTable.hs b/libraries/base/codepages/MakeTable.hs index 7b3328e2d8..394d447a6d 100644 --- a/libraries/base/codepages/MakeTable.hs +++ b/libraries/base/codepages/MakeTable.hs @@ -73,12 +73,12 @@ parseLine s = case words s of readHex' :: Enum a => String -> a readHex' ('0':'x':s) = case readHex s of [(n,"")] -> toEnum n -- explicitly call toEnum to catch overflow errors. - _ -> error $ "Can't read hex: " ++ show s -readHex' s = error $ "Can't read hex: " ++ show s + _ -> errorWithoutStackTrace $ "Can't read hex: " ++ show s +readHex' s = errorWithoutStackTrace $ "Can't read hex: " ++ show s readCharHex :: String -> Char readCharHex s = if c > fromEnum (maxBound :: Word16) - then error "Can't handle non-BMP character." + then errorWithoutStackTrace "Can't handle non-BMP character." else toEnum c where c = readHex' s @@ -255,7 +255,7 @@ showHex' s = "\\x" ++ showHex s "" repDualByte :: Enum c => c -> String repDualByte c - | n >= 2^(16::Int) = error "value is too high!" + | n >= 2^(16::Int) = errorWithoutStackTrace "value is too high!" -- NOTE : this assumes little-endian architecture. But we're only using this on Windows, -- so it's probably OK. | otherwise = showHex' (n `mod` 256) ++ showHex' (n `div` 256) diff --git a/libraries/base/tests/readFloat.stderr b/libraries/base/tests/readFloat.stderr index a3a84648f0..929906187e 100644 --- a/libraries/base/tests/readFloat.stderr +++ b/libraries/base/tests/readFloat.stderr @@ -1,3 +1 @@ readFloat: Prelude.read: no parse -CallStack (from ImplicitParams): - error, called at libraries/base/Text/Read.hs:90:17 in base:Text.Read diff --git a/libraries/stm b/libraries/stm -Subproject b49b5060d5e78a9ee2fa6a069a7195654ebdf08 +Subproject 844f84c21f94282187f35a6684d3c3c9f32cf2d |