{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
, ExistentialQuantification
, MagicHash
, RecordWildCards
, PatternSynonyms
#-}
{-# LANGUAGE TypeInType #-}
{-# OPTIONS_HADDOCK not-home #-}
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 {-# SOURCE #-} GHC.Stack.CCS
import GHC.Exception.Type
throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
Exception e => e -> a
throw :: e -> a
throw e
e = SomeException -> a
forall b a. b -> a
raise# (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)
data ErrorCall = ErrorCallWithLocation String String
deriving ( Eq
, Ord
)
pattern ErrorCall :: String -> ErrorCall
pattern $bErrorCall :: String -> ErrorCall
$mErrorCall :: forall r. ErrorCall -> (String -> r) -> (Void# -> r) -> r
ErrorCall err <- ErrorCallWithLocation err _ where
ErrorCall String
err = String -> String -> ErrorCall
ErrorCallWithLocation String
err String
""
{-# COMPLETE ErrorCall #-}
instance Exception ErrorCall
instance Show ErrorCall where
showsPrec :: Int -> ErrorCall -> ShowS
showsPrec Int
_ (ErrorCallWithLocation String
err String
"") = String -> ShowS
showString String
err
showsPrec Int
_ (ErrorCallWithLocation String
err String
loc) =
String -> ShowS
showString String
err ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
loc
errorCallException :: String -> SomeException
errorCallException :: String -> SomeException
errorCallException String
s = ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> ErrorCall
ErrorCall String
s)
errorCallWithCallStackException :: String -> CallStack -> SomeException
errorCallWithCallStackException :: String -> CallStack -> SomeException
errorCallWithCallStackException String
s CallStack
stk = IO SomeException -> SomeException
forall a. IO a -> a
unsafeDupablePerformIO (IO SomeException -> SomeException)
-> IO SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ do
[String]
ccsStack <- IO [String]
currentCallStack
let
implicitParamCallStack :: [String]
implicitParamCallStack = CallStack -> [String]
prettyCallStackLines CallStack
stk
ccsCallStack :: [String]
ccsCallStack = [String] -> [String]
showCCSStack [String]
ccsStack
stack :: String
stack = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
implicitParamCallStack [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ccsCallStack
SomeException -> IO SomeException
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> IO SomeException)
-> SomeException -> IO SomeException
forall a b. (a -> b) -> a -> b
$ ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> String -> ErrorCall
ErrorCallWithLocation String
s String
stack)
showCCSStack :: [String] -> [String]
showCCSStack :: [String] -> [String]
showCCSStack [] = []
showCCSStack [String]
stk = String
"CallStack (from -prof):" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
stk)
prettySrcLoc :: SrcLoc -> String
prettySrcLoc :: SrcLoc -> String
prettySrcLoc SrcLoc {Int
String
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..}
= (String -> ShowS) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
foldr String -> ShowS
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
]
prettyCallStack :: 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 = case CallStack -> [(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 -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ((String, SrcLoc) -> String) -> (String, SrcLoc) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> String
prettyCallSite) [(String, SrcLoc)]
stk
where
prettyCallSite :: (String, SrcLoc) -> String
prettyCallSite (String
f, SrcLoc
loc) = String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", called at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
prettySrcLoc SrcLoc
loc