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