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.

1 files changed, 45 insertions, 1 deletions

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