    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ImplicitParams #-}
    {-# LANGUAGE RankNTypes #-}

    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 :: 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

    -- Yeah, this uses skivvy implementation details.
    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

    -- | 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 :: 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