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

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

import GHC.Stack

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