{-# 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 :: 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 -- Yeah, this uses skivvy implementation details. withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b) withLexicalCallStack :: (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 = 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 -- | 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 :: 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