Unify CallStack handling in ghc

Here we introduce compatibility wrappers for HasCallStack constraints.
This is necessary as we must support GHC 7.10.1 which lacks sane call
stack support. We also introduce another constraint synonym,
HasDebugCallStack, which only provides a call stack when DEBUG is set.

6 files changed, 72 insertions, 106 deletions

diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs
index ca8438eec1..6309aecb3a 100644
--- a/compiler/simplStg/RepType.hs
+++ b/compiler/simplStg/RepType.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module RepType
   ( -- * Code generator views onto Types
@@ -332,14 +333,14 @@ fitsIn ty1 ty2
 ********************************************************************** -}
 
 -- | Discovers the primitive representation of a more abstract 'UnaryType'
-typePrimRep :: UnaryType -> PrimRep
+typePrimRep :: HasDebugCallStack => UnaryType -> PrimRep
 typePrimRep ty = kindPrimRep (text "kindRep ty" <+> ppr ty $$ ppr (typeKind ty))
                              (typeKind ty)
 
 -- | Find the runtime representation of a 'TyCon'. Defined here to
 -- avoid module loops. Do not call this on unboxed tuples or sums,
 -- because they don't /have/ a runtime representation
-tyConPrimRep :: TyCon -> PrimRep
+tyConPrimRep :: HasDebugCallStack => TyCon -> PrimRep
 tyConPrimRep tc
   = ASSERT2( not (isUnboxedTupleTyCon tc), ppr tc )
     ASSERT2( not (isUnboxedSumTyCon   tc), ppr tc )
@@ -350,7 +351,7 @@ tyConPrimRep tc
 
 -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep'
 -- of values of types of this kind.
-kindPrimRep :: SDoc -> Kind -> PrimRep
+kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> PrimRep
 kindPrimRep doc ki
   | Just ki' <- coreViewOneStarKind ki
   = kindPrimRep doc ki'
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 728460045b..0b5f07301a 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -65,9 +65,6 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Data.List
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-import GHC.Stack (CallStack)
-#endif
 
 {-
 ************************************************************************
@@ -138,21 +135,11 @@ mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
 mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
 mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
 
-substPredOrigin ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> PredOrigin -> PredOrigin
+substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
 substPredOrigin subst (PredOrigin pred origin t_or_k)
   = PredOrigin (substTy subst pred) origin t_or_k
 
-substThetaOrigin ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> ThetaOrigin -> ThetaOrigin
+substThetaOrigin :: HasCallStack => TCvSubst -> ThetaOrigin -> ThetaOrigin
 substThetaOrigin subst = map (substPredOrigin subst)
 
 data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index cd221a2ebf..8302af9019 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -167,9 +167,6 @@ import UniqFM
 import qualified Data.Data as Data hiding ( TyCon )
 import Data.List
 import Data.IORef ( IORef )   -- for CoercionHole
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-import GHC.Stack (CallStack)
-#endif
 
 {-
 %************************************************************************
@@ -1986,12 +1983,7 @@ ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])
 -}
 
 -- | Type substitution, see 'zipTvSubst'
-substTyWith ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    [TyVar] -> [Type] -> Type -> Type
+substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type
 -- Works only if the domain of the substitution is a
 -- superset of the type being substituted into
 substTyWith tvs tys = ASSERT( length tvs == length tys )
@@ -2018,12 +2010,7 @@ substTyWithInScope in_scope tvs tys ty =
   where tenv = zipTyEnv tvs tys
 
 -- | Coercion substitution, see 'zipTvSubst'
-substCoWith ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    [TyVar] -> [Type] -> Coercion -> Coercion
+substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion
 substCoWith tvs tys = ASSERT( length tvs == length tys )
                       substCo (zipTvSubst tvs tys)
 
@@ -2075,11 +2062,7 @@ isValidTCvSubst (TCvSubst in_scope tenv cenv) =
 
 -- | This checks if the substitution satisfies the invariant from
 -- Note [The substitution invariant].
-checkValidSubst ::
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> [Type] -> [Coercion] -> a -> a
+checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a
 checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
   = ASSERT2( isValidTCvSubst subst,
              text "in_scope" <+> ppr in_scope $$
@@ -2111,12 +2094,7 @@ checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
 -- | Substitute within a 'Type'
 -- The substitution has to satisfy the invariants described in
 -- Note [The substitution invariant].
-substTy ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> Type  -> Type
+substTy :: HasCallStack => TCvSubst -> Type  -> Type
 substTy subst ty
   | isEmptyTCvSubst subst = ty
   | otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty
@@ -2134,12 +2112,7 @@ substTyUnchecked subst ty
 -- | Substitute within several 'Type's
 -- The substitution has to satisfy the invariants described in
 -- Note [The substitution invariant].
-substTys ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> [Type] -> [Type]
+substTys :: HasCallStack => TCvSubst -> [Type] -> [Type]
 substTys subst tys
   | isEmptyTCvSubst subst = tys
   | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys
@@ -2157,12 +2130,7 @@ substTysUnchecked subst tys
 -- | Substitute within a 'ThetaType'
 -- The substitution has to satisfy the invariants described in
 -- Note [The substitution invariant].
-substTheta ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> ThetaType -> ThetaType
+substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType
 substTheta = substTys
 
 -- | Substitute within a 'ThetaType' disabling the sanity checks.
@@ -2218,12 +2186,7 @@ lookupTyVar (TCvSubst _ tenv _) tv
 -- | Substitute within a 'Coercion'
 -- The substitution has to satisfy the invariants described in
 -- Note [The substitution invariant].
-substCo ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> Coercion -> Coercion
+substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion
 substCo subst co
   | isEmptyTCvSubst subst = co
   | otherwise = checkValidSubst subst [] [co] $ subst_co subst co
@@ -2241,12 +2204,7 @@ substCoUnchecked subst co
 -- | Substitute within several 'Coercion's
 -- The substitution has to satisfy the invariants described in
 -- Note [The substitution invariant].
-substCos ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> [Coercion] -> [Coercion]
+substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion]
 substCos subst cos
   | isEmptyTCvSubst subst = cos
   | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos
@@ -2341,12 +2299,7 @@ substCoVars subst cvs = map (substCoVar subst) cvs
 lookupCoVar :: TCvSubst -> Var  -> Maybe Coercion
 lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v
 
-substTyVarBndr ::
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-    (?callStack :: CallStack) =>
-#endif
-    TCvSubst -> TyVar -> (TCvSubst, TyVar)
+substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)
 substTyVarBndr = substTyVarBndrCallback substTy
 
 -- | Like 'substTyVarBndr' but disables sanity checks.
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index b400fa6b32..89dd5b4fae 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -26,12 +27,7 @@ import Control.Monad
 import Control.Monad.Trans.Maybe
 import Control.Exception (catch, SomeException(..))
 import Data.Maybe
-#if __GLASGOW_HASKELL__ >= 800
-import GHC.Stack
-#else
-import GHC.Exts (Constraint)
-type HasCallStack = (() :: Constraint)
-#endif
+import Util (HasCallStack)
 
 infixr 4 `orElse`
 
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index ee0147d308..472af2201e 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -118,9 +118,6 @@ import Data.List (intersperse)
 
 import GHC.Fingerprint
 import GHC.Show         ( showMultiLineString )
-#if __GLASGOW_HASKELL__ > 710
-import GHC.Stack
-#endif
 
 {-
 ************************************************************************
@@ -1074,9 +1071,13 @@ doOrDoes _   = text "do"
 ************************************************************************
 -}
 
-pprPanic :: String -> SDoc -> a
+callStackDoc :: HasCallStack => SDoc
+callStackDoc =
+    hang (text "Call stack:") 4 (vcat $ map text $ lines prettyCurrentCallStack)
+
+pprPanic :: HasCallStack => String -> SDoc -> a
 -- ^ Throw an exception saying "bug in GHC"
-pprPanic    = panicDoc
+pprPanic s doc = panicDoc s (doc $$ callStackDoc)
 
 pprSorry :: String -> SDoc -> a
 -- ^ Throw an exception saying "this isn't finished yet"
@@ -1101,13 +1102,8 @@ pprTraceIt desc x = pprTrace desc (ppr x) x
 
 -- | If debug output is on, show some 'SDoc' on the screen along
 -- with a call stack when available.
-#if __GLASGOW_HASKELL__ > 710
-pprSTrace :: (?callStack :: CallStack) => SDoc -> a -> a
-pprSTrace = pprTrace (prettyCallStack ?callStack)
-#else
-pprSTrace :: SDoc -> a -> a
-pprSTrace = pprTrace "no callstack info"
-#endif
+pprSTrace :: HasCallStack => SDoc -> a -> a
+pprSTrace doc = pprTrace "" (doc $$ callStackDoc)
 
 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 -- ^ Just warn about an assertion failure, recording the given file and line number.
@@ -1122,22 +1118,11 @@ warnPprTrace True   file  line  msg x
 
 -- | Panic with an assertation failure, recording the given file and
 -- line number. Should typically be accessed with the ASSERT family of macros
-#if __GLASGOW_HASKELL__ > 710
-assertPprPanic :: (?callStack :: CallStack) => String -> Int -> SDoc -> a
+assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a
 assertPprPanic _file _line msg
   = pprPanic "ASSERT failed!" doc
   where
-    doc = sep [ text (prettyCallStack ?callStack)
-              , msg ]
-#else
-assertPprPanic :: String -> Int -> SDoc -> a
-assertPprPanic file line msg
-  = pprPanic "ASSERT failed!" doc
-  where
-    doc = sep [ hsep [ text "file", text file
-                     , text "line", int line ]
-              , msg ]
-#endif
+    doc = sep [ msg, callStackDoc ]
 
 pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
 pprDebugAndThen dflags cont heading pretty_msg
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 0b16fba72d..687ced2f47 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -1,6 +1,14 @@
 -- (c) The University of Glasgow 2006
 
-{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE BangPatterns #-}
+#if __GLASGOW_HASKELL__ < 800
+-- For CallStack business
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE FlexibleContexts #-}
+#endif
 
 -- | Highly random utility functions
 --
@@ -110,6 +118,12 @@ module Util (
 
         -- * Hashing
         hashString,
+
+        -- * Call stacks
+        GHC.Stack.CallStack,
+        HasCallStack,
+        HasDebugCallStack,
+        prettyCurrentCallStack,
     ) where
 
 #include "HsVersions.h"
@@ -123,6 +137,7 @@ import System.IO.Unsafe ( unsafePerformIO )
 import Data.List        hiding (group)
 
 import GHC.Exts
+import qualified GHC.Stack
 
 import Control.Applicative ( liftA2 )
 import Control.Monad    ( liftM )
@@ -1260,3 +1275,32 @@ mulHi :: Int32 -> Int32 -> Int32
 mulHi a b = fromIntegral (r `shiftR` 32)
    where r :: Int64
          r = fromIntegral a * fromIntegral b
+
+-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.
+#if __GLASGOW_HASKELL__ >= 800
+type HasCallStack = GHC.Stack.HasCallStack
+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
+type HasCallStack = (?callStack :: GHC.Stack.CallStack)
+-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
+#else
+type HasCallStack = (() :: Constraint)
+#endif
+
+-- | A call stack constraint, but only when 'isDebugOn'.
+#if DEBUG
+type HasDebugCallStack = HasCallStack
+#else
+type HasDebugCallStack = (() :: Constraint)
+#endif
+
+-- | Pretty-print the current callstack
+#if __GLASGOW_HASKELL__ >= 800
+prettyCurrentCallStack :: HasCallStack => String
+prettyCurrentCallStack = GHC.Stack.prettyCallStack GHC.Stack.callStack
+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
+prettyCurrentCallStack :: (?callStack :: GHC.Stack.CallStack) => String
+prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack
+#else
+prettyCurrentCallStack :: HasCallStack => String
+prettyCurrentCallStack = "Call stack unavailable"
+#endif