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