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