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

module Distribution.Compat.Stack
  ( WithCallStack
  , CallStack
  , annotateCallStackIO
  , withFrozenCallStack
  , withLexicalCallStack
  , callStack
  , prettyCallStack
  , parentSrcLocPrefix
  ) where

import GHC.Stack
import System.IO.Error

type WithCallStack a = HasCallStack => a

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

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

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