Commit 380b25ea authored by Eric Seidel's avatar Eric Seidel Committed by Ben Gamari
Browse files

Allow CallStacks to be frozen

This introduces "freezing," an operation which prevents further
locations from being appended to a CallStack.  Library authors may want
to prevent CallStacks from exposing implementation details, as a matter
of hygiene. For example, in

```
head [] = error "head: empty list"

ghci> head []
*** Exception: head: empty list
CallStack (from implicit params):
  error, called at ...
```

including the call-site of `error` in `head` is not strictly necessary
as the error message already specifies clearly where the error came
from.

So we add a function `freezeCallStack` that wraps an existing CallStack,
preventing further call-sites from being pushed onto it. In other words,

```
pushCallStack callSite (freezeCallStack callStack) = freezeCallStack callStack
```

Now we can define `head` to not produce a CallStack at all

```
head [] =
  let ?callStack = freezeCallStack emptyCallStack
  in error "head: empty list"

ghci> head []
*** Exception: head: empty list
CallStack (from implicit params):
  error, called at ...
```

---

1. We add the `freezeCallStack` and `emptyCallStack` and update the
   definition of `CallStack` to support this functionality.

2. We add `errorWithoutStackTrace`, a variant of `error` that does not
   produce a stack trace, using this feature. I think this is a sensible
   wrapper function to provide in case users want it.

3. We replace uses of `error` in base with `errorWithoutStackTrace`. The
   rationale is that base does not export any functions that use CallStacks
   (except for `error` and `undefined`) so there's no way for the stack
   traces (from Implicit CallStacks) to include user-defined functions.
   They'll only contain the call to `error` itself. As base already has a
   good habit of providing useful error messages that name the triggering
   function, the stack trace really just adds noise to the error. (I don't
   have a strong opinion on whether we should include this third commit,
   but the change was very mechanical so I thought I'd include it anyway in
   case there's interest)

4. Updates tests in `array` and `stm` submodules

Test Plan: ./validate, new test is T11049

Reviewers: simonpj, nomeata, goldfire, austin, hvr, bgamari

Reviewed By: simonpj

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1628

GHC Trac Issues: #11049
parent 78248702
......@@ -44,12 +44,10 @@ import TcEvidence
import TcType
import Type
import Coercion
import TysWiredIn ( mkListTy, mkBoxedTupleTy, charTy
, typeNatKind, typeSymbolKind )
import TysWiredIn ( typeNatKind, typeSymbolKind )
import Id
import MkId(proxyHashId)
import Class
import DataCon ( dataConTyCon )
import Name
import IdInfo ( IdDetails(..) )
import VarSet
......@@ -1147,11 +1145,9 @@ help GHC by manually keeping the 'rep' *outside* the lambda.
dsEvCallStack :: EvCallStack -> DsM CoreExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
dsEvCallStack cs = do
df <- getDynFlags
m <- getModule
srcLocDataCon <- dsLookupDataCon srcLocDataConName
let srcLocTyCon = dataConTyCon srcLocDataCon
let srcLocTy = mkTyConTy srcLocTyCon
df <- getDynFlags
m <- getModule
srcLocDataCon <- dsLookupDataCon srcLocDataConName
let mkSrcLoc l =
liftM (mkCoreConApps srcLocDataCon)
(sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
......@@ -1163,26 +1159,12 @@ dsEvCallStack cs = do
, return $ mkIntExprInt df (srcSpanEndCol l)
])
-- Be careful to use [Char] instead of String here to avoid
-- unnecessary dependencies on GHC.Base, particularly when
-- building GHC.Err.absentError
let callSiteTy = mkBoxedTupleTy [mkListTy charTy, srcLocTy]
emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName
matchId <- newSysLocalDs $ mkListTy callSiteTy
callStackDataCon <- dsLookupDataCon callStackDataConName
let callStackTyCon = dataConTyCon callStackDataCon
let callStackTy = mkTyConTy callStackTyCon
let emptyCS = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy]
pushCSVar <- dsLookupGlobalId pushCallStackName
let pushCS name loc rest =
mkWildCase rest callStackTy callStackTy
[( DataAlt callStackDataCon
, [matchId]
, mkCoreConApps callStackDataCon
[mkConsExpr callSiteTy
(mkCoreTup [name, loc])
(Var matchId)]
)]
mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
let mkPush name loc tm = do
nameExpr <- mkStringExprFS name
locExpr <- mkSrcLoc loc
......
......@@ -328,6 +328,7 @@ basicKnownKeyNames
-- Source locations
callStackDataConName, callStackTyConName,
emptyCallStackName, pushCallStackName,
srcLocDataConName,
-- Annotation type checking
......@@ -1350,11 +1351,16 @@ isLabelClassName
= clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey
-- Source Locations
callStackDataConName, callStackTyConName, srcLocDataConName :: Name
callStackDataConName, callStackTyConName, emptyCallStackName, pushCallStackName,
srcLocDataConName :: Name
callStackDataConName
= dcQual gHC_STACK_TYPES (fsLit "CallStack") callStackDataConKey
callStackTyConName
= tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey
emptyCallStackName
= varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey
pushCallStackName
= varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey
srcLocDataConName
= dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey
......@@ -2162,6 +2168,9 @@ memptyClassOpKey = mkPreludeMiscIdUnique 514
mappendClassOpKey = mkPreludeMiscIdUnique 515
mconcatClassOpKey = mkPreludeMiscIdUnique 516
emptyCallStackKey, pushCallStackKey :: Unique
emptyCallStackKey = mkPreludeMiscIdUnique 517
pushCallStackKey = mkPreludeMiscIdUnique 518
{-
************************************************************************
......
......@@ -393,7 +393,7 @@ See ``changelog.md`` in the ``base`` package for full release notes.
- ``GHC.Stack`` exports two new types ``SrcLoc`` and ``CallStack``. A
``SrcLoc`` contains package, module, and file names, as well as start
and end positions. A ``CallStack`` is a ``[(String, SrcLoc)]``,
and end positions. A ``CallStack`` is essentially a ``[(String, SrcLoc)]``,
sorted by most-recent call.
- ``error`` and ``undefined`` will now report a partial stack-trace
......
......@@ -8282,14 +8282,14 @@ a type signature for ``y``, then ``y`` will get type
``let`` will see the inner binding of ``?x``, so ``(f 9)`` will return
``14``.
.. _implicit-parameters-special:
.. _implicit-callstacks:
Special implicit parameters
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Implicit CallStacks
~~~~~~~~~~~~~~~~~~~
Implicit parameters of the new ``base`` type ``GHC.Stack.CallStack`` are
treated specially in function calls, the solver automatically appends
the source location of the call to the ``CallStack`` in the
treated specially in function calls, the solver automatically pushes
the source location of the call onto the ``CallStack`` in the
environment. For example
::
......@@ -8342,6 +8342,24 @@ package, module, and file name, as well as the line and column numbers.
GHC will infer ``CallStack`` constraints using the same rules as for
ordinary implicit parameters.
``GHC.Stack`` additionally exports a function ``freezeCallStack`` that
allows users to freeze a ``CallStack``, preventing any future push
operations from having an effect. This can be used by library authors
to prevent ``CallStack``s from exposing unecessary implementation
details. Consider the ``head`` example above, the ``myerror`` line in
the printed stack is not particularly enlightening, so we might choose
to surpress it by freezing the ``CallStack`` that we pass to ``myerror``.
::
head :: (?callStack :: CallStack) => [a] -> a
head [] = let ?callStack = freezeCallStack ?callStack in myerror "empty"
head (x:xs) = x
ghci> head []]
*** Exception: empty
CallStack (from ImplicitParams):
head, called at Bad.hs:12:7 in main:Bad
.. _kinding:
......
Subproject commit f643793b3fbffd7419f403bedc65b7ac06dff0cd
Subproject commit 6551ad9edaca1634a8149ad9c27a72feb456d4e1
......@@ -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
......
......@@ -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"))
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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
-----------------------------------------------------------------------------
......
......@@ -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'
......
......@@ -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