{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ImplicitParams #-}
module Distribution.Compat.Stack (
WithCallStack,
CallStack,
annotateCallStackIO,
withFrozenCallStack,
withLexicalCallStack,
callStack,
prettyCallStack,
parentSrcLocPrefix
) where
import System.IO.Error
#ifdef MIN_VERSION_base
#if MIN_VERSION_base(4,8,1)
#define GHC_STACK_SUPPORTED 1
#endif
#endif
#ifdef GHC_STACK_SUPPORTED
import GHC.Stack
#endif
#ifdef GHC_STACK_SUPPORTED
#if MIN_VERSION_base(4,9,0)
type WithCallStack a = HasCallStack => a
#elif MIN_VERSION_base(4,8,1)
type WithCallStack a = (?callStack :: CallStack) => a
#endif
#if !MIN_VERSION_base(4,9,0)
-- NB: Can't say WithCallStack (WithCallStack a -> a);
-- Haskell doesn't support this kind of implicit parameter!
-- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html
-- Since this function doesn't do anything, it's OK to
-- give it a less good type.
withFrozenCallStack :: WithCallStack (a -> a)
withFrozenCallStack x = x
callStack :: (?callStack :: CallStack) => CallStack
callStack = ?callStack
prettyCallStack :: CallStack -> String
prettyCallStack = showCallStack
#endif
-- | Give the *parent* of the person who invoked this;
-- so it's most suitable for being called from a utility function.
-- You probably want to call this using 'withFrozenCallStack'; otherwise
-- it's not very useful. We didn't implement this for base-4.8.1
-- because we cannot rely on freezing to have taken place.
--
parentSrcLocPrefix :: WithCallStack String
#if MIN_VERSION_base(4,9,0)
parentSrcLocPrefix =
case getCallStack callStack of
(_:(_, loc):_) -> showLoc loc
[(_, loc)] -> showLoc loc
[] -> error "parentSrcLocPrefix: empty call stack"
where
showLoc loc =
srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": "
#else
parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
#endif
-- Yeah, this uses skivvy implementation details.
withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack f =
let stk = ?callStack
in \x -> let ?callStack = stk in f x
#else
data CallStack = CallStack
deriving (Eq, Show)
type WithCallStack a = a
withFrozenCallStack :: a -> a
withFrozenCallStack x = x
callStack :: CallStack
callStack = CallStack
prettyCallStack :: CallStack -> String
prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)"
parentSrcLocPrefix :: String
parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
withLexicalCallStack :: (a -> IO b) -> a -> IO b
withLexicalCallStack f = f
#endif
-- | This function is for when you *really* want to add a call
-- stack to raised IO, but you don't have a
-- 'Distribution.Verbosity.Verbosity' so you can't use
-- 'Distribution.Simple.Utils.annotateIO'. If you have a 'Verbosity',
-- please use that function instead.
annotateCallStackIO :: WithCallStack (IO a -> IO a)
annotateCallStackIO = modifyIOError f
where
f ioe = ioeSetErrorString ioe
. wrapCallStack
$ ioeGetErrorString ioe
wrapCallStack s =
prettyCallStack callStack ++ "\n" ++ s