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)
withFrozenCallStack :: WithCallStack (a -> a)
withFrozenCallStack x = x
callStack :: (?callStack :: CallStack) => CallStack
callStack = ?callStack
prettyCallStack :: CallStack -> String
prettyCallStack = showCallStack
#endif
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
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
annotateCallStackIO :: WithCallStack (IO a -> IO a)
annotateCallStackIO = modifyIOError f
where
f ioe = ioeSetErrorString ioe
. wrapCallStack
$ ioeGetErrorString ioe
wrapCallStack s =
prettyCallStack callStack ++ "\n" ++ s