{-# 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)
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 :: WithCallStack String
parentSrcLocPrefix =
case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
((String, SrcLoc)
_:(String
_, SrcLoc
loc):[(String, SrcLoc)]
_) -> SrcLoc -> String
showLoc SrcLoc
loc
[(String
_, SrcLoc
loc)] -> SrcLoc -> String
showLoc SrcLoc
loc
[] -> String -> String
forall a. HasCallStack => String -> a
error String
"parentSrcLocPrefix: empty call stack"
where
showLoc :: SrcLoc -> String
showLoc SrcLoc
loc =
SrcLoc -> String
srcLocFile SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
#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 :: forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack a -> WithCallStack (IO b)
f =
let stk :: CallStack
stk = HasCallStack
CallStack
?callStack
in \a
x -> let ?callStack = HasCallStack
CallStack
stk in a -> WithCallStack (IO b)
f a
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 :: forall a. WithCallStack (IO a -> IO a)
annotateCallStackIO = (IOError -> IOError) -> IO a -> IO a
forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError IOError -> IOError
f
where
f :: IOError -> IOError
f IOError
ioe = IOError -> String -> IOError
ioeSetErrorString IOError
ioe
(String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
wrapCallStack
(String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ IOError -> String
ioeGetErrorString IOError
ioe
wrapCallStack :: String -> String
wrapCallStack String
s =
CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s