Distribution/Compat/Stack.hs

    {-# 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