module GHC.Stack (
currentCallStack,
whoCreated,
CostCentreStack,
CostCentre,
getCurrentCCS,
getCCSOf,
ccsCC,
ccsParent,
ccLabel,
ccModule,
ccSrcSpan,
ccsToStrings,
renderStack
) where
import Foreign
import Foreign.C
import GHC.IO
import GHC.Base
import GHC.Ptr
import GHC.Foreign as GHC
import GHC.IO.Encoding
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
ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
ccLabel :: Ptr CostCentre -> IO CString
ccLabel p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
ccModule :: Ptr CostCentre -> IO CString
ccModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
ccSrcSpan :: Ptr CostCentre -> IO CString
ccSrcSpan p = ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
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)
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4