{-# OPTIONS_GHC -optc-DPROFILING #-}
{-# LINE 1 "GHC/Stack.hsc" #-}
{-# LANGUAGE Trustworthy #-}
{-# LINE 2 "GHC/Stack.hsc" #-}
{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
module GHC.Stack (
currentCallStack,
whoCreated,
errorWithStackTrace,
CallStack,
getCallStack,
showCallStack,
CostCentreStack,
CostCentre,
getCurrentCCS,
getCCSOf,
ccsCC,
ccsParent,
ccLabel,
ccModule,
ccSrcSpan,
ccsToStrings,
renderStack
) where
import Data.List ( unlines )
import Foreign
import Foreign.C
import GHC.IO
import GHC.Base
import GHC.Ptr
import GHC.Foreign as GHC
import GHC.IO.Encoding
import GHC.Exception
import GHC.List ( concatMap, null, reverse )
import GHC.Show
import GHC.SrcLoc
{-# LINE 61 "GHC/Stack.hsc" #-}
{-# LINE 62 "GHC/Stack.hsc" #-}
data CostCentreStack
data CostCentre
getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
getCurrentCCS dummy = IO $ \s ->
case getCurrentCCS# dummy s of
(# s', addr #) -> (# s', Ptr addr #)
getCCSOf :: a -> IO (Ptr CostCentreStack)
getCCSOf obj = IO $ \s ->
case getCCSOf# obj s of
(# s', addr #) -> (# s', Ptr addr #)
ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
ccsCC p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 78 "GHC/Stack.hsc" #-}
ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 81 "GHC/Stack.hsc" #-}
ccLabel :: Ptr CostCentre -> IO CString
ccLabel p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 84 "GHC/Stack.hsc" #-}
ccModule :: Ptr CostCentre -> IO CString
ccModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 87 "GHC/Stack.hsc" #-}
ccSrcSpan :: Ptr CostCentre -> IO CString
ccSrcSpan p = ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
{-# LINE 90 "GHC/Stack.hsc" #-}
currentCallStack :: IO [String]
currentCallStack = ccsToStrings =<< getCurrentCCS ()
ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings ccs0 = go ccs0 []
where
go ccs acc
| ccs == nullPtr = return acc
| otherwise = do
cc <- ccsCC ccs
lbl <- GHC.peekCString utf8 =<< ccLabel cc
mdl <- GHC.peekCString utf8 =<< ccModule cc
loc <- GHC.peekCString utf8 =<< ccSrcSpan cc
parent <- ccsParent ccs
if (mdl == "MAIN" && lbl == "MAIN")
then return acc
else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
whoCreated :: a -> IO [String]
whoCreated obj = do
ccs <- getCCSOf obj
ccsToStrings ccs
renderStack :: [String] -> String
renderStack strs = "Stack trace:" ++ concatMap ("\n "++) (reverse strs)
errorWithStackTrace :: String -> a
errorWithStackTrace x = unsafeDupablePerformIO $ do
stack <- ccsToStrings =<< getCurrentCCS x
if null stack
then throwIO (ErrorCall x)
else throwIO (ErrorCall (x ++ '\n' : renderStack stack))
data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] }
deriving (Show, Eq)
showCallStack :: CallStack -> String
showCallStack (CallStack (root:rest))
= unlines (showCallSite root : map (indent . showCallSite) rest)
where
indent l = " " ++ l
showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
showCallStack _ = error "CallStack cannot be empty!"