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