{-# LANGUAGE ImplicitParams #-}{-# LANGUAGE NoImplicitPrelude #-}{-# LANGUAGE RecordWildCards #-}{-# LANGUAGE RankNTypes #-}{-# LANGUAGE Trustworthy #-}------------------------------------------------------------------------------- |-- Module : GHC.Internal.Stack-- Copyright : (c) The University of Glasgow 2011-- License : see libraries/base/LICENSE---- Maintainer : ghc-devs@haskell.org-- Stability : internal-- Portability : non-portable (GHC Extensions)---- Access to GHC's call-stack simulation---- @since base-4.5.0.0-----------------------------------------------------------------------------moduleGHC.Internal.Stack (errorWithStackTrace ,-- * Profiling call stackscurrentCallStack ,whoCreated ,-- * HasCallStack call stacksCallStack ,HasCallStack ,callStack ,emptyCallStack ,freezeCallStack ,fromCallSiteList ,getCallStack ,popCallStack ,pushCallStack ,withFrozenCallStack ,prettyCallStackLines ,prettyCallStack ,-- * Source locationsSrcLoc (..),prettySrcLoc ,-- * InternalsCostCentreStack ,CostCentre ,getCurrentCCS ,getCCSOf ,clearCCS ,ccsCC ,ccsParent ,ccLabel ,ccModule ,ccSrcSpan ,ccsToStrings ,renderStack )whereimportGHC.Internal.Show importGHC.Internal.Stack.CCS importGHC.Internal.Stack.Types importGHC.Internal.Base importGHC.Internal.Data.OldList (intercalate )importGHC.Internal.Exception importGHC.Internal.IO (unsafeDupablePerformIO ,throwIO )-- | Like the function 'error', but appends a stack trace to the error-- message if one is available.---- @since base-4.7.0.0{-# DEPRECATEDerrorWithStackTrace"'error' appends the call stack now"#-}-- DEPRECATED in 8.0.1errorWithStackTrace ::String ->a errorWithStackTrace :: forall a. 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
$ ErrorCall -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> ErrorCall
ErrorCall String
x )-- | Pop the most recent call-site off the 'CallStack'.---- This function, like 'pushCallStack', has no effect on a frozen 'CallStack'.---- @since base-4.9.0.0popCallStack ::CallStack ->CallStack popCallStack :: CallStack -> CallStack
popCallStack CallStack
stk =caseCallStack
stk ofCallStack
EmptyCallStack ->String -> CallStack
forall a. String -> a
errorWithoutStackTrace String
"popCallStack: empty stack"PushCallStack String
_SrcLoc
_CallStack
stk' ->CallStack
stk' FreezeCallStack CallStack
_->CallStack
stk {-# INLINEpopCallStack #-}-- | Return the current 'CallStack'.---- Does *not* include the call-site of 'callStack'.---- @since base-4.9.0.0callStack ::HasCallStack =>CallStack callStack :: HasCallStack => CallStack
callStack =caseHasCallStack
CallStack
?callStack ofCallStack
EmptyCallStack ->CallStack
EmptyCallStack CallStack
_->CallStack -> CallStack
popCallStack HasCallStack
CallStack
?callStack {-# INLINEcallStack #-}-- | Perform some computation without adding new entries to the 'CallStack'.---- @since base-4.9.0.0withFrozenCallStack ::HasCallStack =>(HasCallStack =>a )->a withFrozenCallStack :: forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => a
do_this =-- we pop the stack before freezing it to remove-- withFrozenCallStack's call-sitelet?callStack=CallStack -> CallStack
freezeCallStack (CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack )ina
HasCallStack => a
do_this -- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot-- files. See Note [Definition of CallStack]-- | Pretty print a 'SrcLoc'.---- @since 4.9.0.0prettySrcLoc ::SrcLoc ->String prettySrcLoc :: SrcLoc -> String
prettySrcLoc SrcLoc {Int
String
srcLocPackage :: String
srcLocModule :: String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
.. }=(String -> String -> String) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
foldr String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
""[String
srcLocFile ,String
":",Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine ,String
":",Int -> String
forall a. Show a => a -> String
show Int
srcLocStartCol ,String
" in ",String
srcLocPackage ,String
":",String
srcLocModule ]-- | Pretty print a 'CallStack'.---- @since 4.9.0.0prettyCallStack ::CallStack ->String prettyCallStack :: CallStack -> String
prettyCallStack =String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"([String] -> String)
-> (CallStack -> [String]) -> CallStack -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [String]
prettyCallStackLines prettyCallStackLines ::CallStack ->[String ]prettyCallStackLines :: CallStack -> [String]
prettyCallStackLines CallStack
cs =caseCallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of[]->[][(String, SrcLoc)]
stk ->String
"CallStack (from HasCallStack):"String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String, SrcLoc) -> String) -> [(String, SrcLoc)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++ )(String -> String)
-> ((String, SrcLoc) -> String) -> (String, SrcLoc) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> String
prettyCallSite )[(String, SrcLoc)]
stk whereprettyCallSite :: (String, SrcLoc) -> String
prettyCallSite (String
f ,SrcLoc
loc )=String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", called at "String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
prettySrcLoc SrcLoc
loc