{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Stack
-- Copyright   :  (c) The University of Glasgow 2011
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Access to GHC's call-stack simulation
--
-- @since 4.5.0.0
-----------------------------------------------------------------------------

{-# LANGUAGE MagicHash, NoImplicitPrelude, ImplicitParams, RankNTypes #-}
module GHC.Stack (
    errorWithStackTrace,

    -- * Profiling call stacks
    currentCallStack,
    whoCreated,

    -- * HasCallStack call stacks
    CallStack, HasCallStack, callStack, emptyCallStack, freezeCallStack,
    fromCallSiteList, getCallStack, popCallStack, prettyCallStack,
    pushCallStack, withFrozenCallStack,

    -- * Source locations
    SrcLoc(..), prettySrcLoc,

    -- * Internals
    CostCentreStack,
    CostCentre,
    getCurrentCCS,
    getCCSOf,
    clearCCS,
    ccsCC,
    ccsParent,
    ccLabel,
    ccModule,
    ccSrcSpan,
    ccsToStrings,
    renderStack
  ) where

import GHC.Stack.CCS
import GHC.Stack.Types
import GHC.IO
import GHC.Base
import GHC.List
import GHC.Exception

-- | Like the function 'error', but appends a stack trace to the error
-- message if one is available.
--
-- @since 4.7.0.0
{-# DEPRECATED errorWithStackTrace "'error' appends the call stack now" #-}
  -- DEPRECATED in 8.0.1
errorWithStackTrace :: String -> a
errorWithStackTrace :: String -> a
errorWithStackTrace String
x = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
   [String]
stack <- Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS String
x
   if [String] -> Bool
forall a. [a] -> Bool
null [String]
stack
      then ErrorCall -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall String
x)
      else ErrorCall -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> String -> ErrorCall
ErrorCallWithLocation String
x ([String] -> String
renderStack [String]
stack))


-- | Pop the most recent call-site off the 'CallStack'.
--
-- This function, like 'pushCallStack', has no effect on a frozen 'CallStack'.
--
-- @since 4.9.0.0
popCallStack :: CallStack -> CallStack
popCallStack :: CallStack -> CallStack
popCallStack CallStack
stk = case CallStack
stk of
  CallStack
EmptyCallStack         -> String -> CallStack
forall a. String -> a
errorWithoutStackTrace String
"popCallStack: empty stack"
  PushCallStack String
_ SrcLoc
_ CallStack
stk' -> CallStack
stk'
  FreezeCallStack CallStack
_      -> CallStack
stk
{-# INLINE popCallStack #-}

-- | Return the current 'CallStack'.
--
-- Does *not* include the call-site of 'callStack'.
--
-- @since 4.9.0.0
callStack :: HasCallStack => CallStack
callStack :: CallStack
callStack =
  case ?callStack::CallStack
CallStack
?callStack of
    CallStack
EmptyCallStack -> CallStack
EmptyCallStack
    CallStack
_              -> CallStack -> CallStack
popCallStack ?callStack::CallStack
CallStack
?callStack
{-# INLINE callStack #-}

-- | Perform some computation without adding new entries to the 'CallStack'.
--
-- @since 4.9.0.0
withFrozenCallStack :: HasCallStack
                    => ( HasCallStack => a )
                    -> a
withFrozenCallStack :: ((?callStack::CallStack) => a) -> a
withFrozenCallStack (?callStack::CallStack) => a
do_this =
  -- we pop the stack before freezing it to remove
  -- withFrozenCallStack's call-site
  let ?callStack = freezeCallStack (popCallStack callStack)
  in a
(?callStack::CallStack) => a
do_this