1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
, ExistentialQuantification
, MagicHash
, RecordWildCards
, PatternSynonyms
#-}
{-# LANGUAGE TypeInType #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Exception
-- Copyright : (c) The University of Glasgow, 1998-2002
-- License : see libraries/base/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC extensions)
--
-- Exceptions and exception-handling functions.
--
-----------------------------------------------------------------------------
module GHC.Exception
( module GHC.Exception.Type
, throw
, ErrorCall(..,ErrorCall)
, errorCallException
, errorCallWithCallStackException
-- re-export CallStack and SrcLoc from GHC.Types
, CallStack, fromCallSiteList, getCallStack, prettyCallStack
, prettyCallStackLines, showCCSStack
, SrcLoc(..), prettySrcLoc
) where
import GHC.Base
import GHC.Show
import GHC.Stack.Types
import Data.List (intercalate, reverse) -- TODO: remove import list?
import GHC.Prim
import GHC.IO.Unsafe
import {-# SOURCE #-} GHC.Stack.CCS
import GHC.Exception.Type
-- | Throw an exception. Exceptions may be thrown from purely
-- functional code, but may only be caught within the 'IO' monad.
--
-- WARNING: You may want to use 'throwIO' instead so that your pure code
-- stays exception-free.
throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
Exception e => e -> a
throw e = raise# (toException e)
-- | This is thrown when the user calls 'error'. The first @String@ is the
-- argument given to 'error', second @String@ is the location.
data ErrorCall = ErrorCallWithLocation String String
deriving ( Eq -- ^ @since 4.7.0.0
, Ord -- ^ @since 4.7.0.0
)
pattern ErrorCall :: String -> ErrorCall
pattern ErrorCall err <- ErrorCallWithLocation err _ where
ErrorCall err = ErrorCallWithLocation err ""
{-# COMPLETE ErrorCall #-}
-- | @since 4.0.0.0
instance Exception ErrorCall
-- | @since 4.0.0.0
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 and prettyCallStack are defined here to avoid hs-boot
-- files. See Note [Definition of CallStack]
-- | Pretty print a 'SrcLoc'.
--
-- @since 4.9.0.0
prettySrcLoc :: SrcLoc -> String
prettySrcLoc SrcLoc {..}
= foldr (++) ""
[ srcLocFile, ":"
, show srcLocStartLine, ":"
, show srcLocStartCol, " in "
, srcLocPackage, ":", srcLocModule
]
-- | Pretty print a 'CallStack'.
--
-- @since 4.9.0.0
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
|
