module GHC.Exception
( module GHC.Exception.Type
, throw
, ErrorCall(..,ErrorCall)
, errorCallException
, errorCallWithCallStackException
, CallStack, fromCallSiteList, getCallStack, prettyCallStack
, prettyCallStackLines, showCCSStack
, SrcLoc(..), prettySrcLoc
) where
import GHC.Base
import GHC.Show
import GHC.Stack.Types
import GHC.OldList
import GHC.Prim
import GHC.IO.Unsafe
import GHC.Stack.CCS
import GHC.Exception.Type
throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
Exception e => e -> a
throw e = raise# (toException e)
data ErrorCall = ErrorCallWithLocation String String
deriving ( Eq
, Ord
)
pattern ErrorCall :: String -> ErrorCall
pattern ErrorCall err <- ErrorCallWithLocation err _ where
ErrorCall err = ErrorCallWithLocation err ""
instance Exception ErrorCall
instance Show ErrorCall where
showsPrec _ (ErrorCallWithLocation err "") = showString err
showsPrec _ (ErrorCallWithLocation err loc) =
showString err . showChar '\n' . showString loc
errorCallException :: String -> SomeException
errorCallException s = toException (ErrorCall s)
errorCallWithCallStackException :: String -> CallStack -> SomeException
errorCallWithCallStackException s stk = unsafeDupablePerformIO $ do
ccsStack <- currentCallStack
let
implicitParamCallStack = prettyCallStackLines stk
ccsCallStack = showCCSStack ccsStack
stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
return $ toException (ErrorCallWithLocation s stack)
showCCSStack :: [String] -> [String]
showCCSStack [] = []
showCCSStack stk = "CallStack (from -prof):" : map (" " ++) (reverse stk)
prettySrcLoc :: SrcLoc -> String
prettySrcLoc SrcLoc {..}
= foldr (++) ""
[ srcLocFile, ":"
, show srcLocStartLine, ":"
, show srcLocStartCol, " in "
, srcLocPackage, ":", srcLocModule
]
prettyCallStack :: CallStack -> String
prettyCallStack = intercalate "\n" . prettyCallStackLines
prettyCallStackLines :: CallStack -> [String]
prettyCallStackLines cs = case getCallStack cs of
[] -> []
stk -> "CallStack (from HasCallStack):"
: map ((" " ++) . prettyCallSite) stk
where
prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc