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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}
-- | Defines a simple exception type and utilities to throw it. The
-- 'PlainGhcException' type is a subset of the 'GHC.Utils.Panic.GhcException'
-- type. It omits the exception constructors that involve
-- pretty-printing via 'GHC.Utils.Outputable.SDoc'.
--
-- There are two reasons for this:
--
-- 1. To avoid import cycles / use of boot files. "GHC.Utils.Outputable" has
-- many transitive dependencies. To throw exceptions from these
-- modules, the functions here can be used without introducing import
-- cycles.
--
-- 2. To reduce the number of modules that need to be compiled to
-- object code when loading GHC into GHCi. See #13101
module GHC.Utils.Panic.Plain
( PlainGhcException(..)
, showPlainGhcException
, panic, sorry, pgmError
, cmdLineError, cmdLineErrorIO
, assertPanic
, assert, assertM, massert
) where
import GHC.Settings.Config
import GHC.Utils.Constants
import GHC.Utils.Exception as Exception
import GHC.Stack
import GHC.Prelude.Basic
import System.IO.Unsafe
-- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits
-- the constructors that involve pretty-printing via
-- 'GHC.Utils.Outputable.SDoc'. Due to the implementation of 'fromException'
-- for 'GHC.Utils.Panic.GhcException', this type can be caught as a
-- 'GHC.Utils.Panic.GhcException'.
--
-- Note that this should only be used for throwing exceptions, not for
-- catching, as 'GHC.Utils.Panic.GhcException' will not be converted to this
-- type when catching.
data PlainGhcException
-- | Some other fatal signal (SIGHUP,SIGTERM)
= PlainSignal Int
-- | Prints the short usage msg after the error
| PlainUsageError String
-- | A problem with the command line arguments, but don't print usage.
| PlainCmdLineError String
-- | The 'impossible' happened.
| PlainPanic String
-- | The user tickled something that's known not to work yet,
-- but we're not counting it as a bug.
| PlainSorry String
-- | An installation problem.
| PlainInstallationError String
-- | An error in the user's code, probably.
| PlainProgramError String
instance Exception PlainGhcException
instance Show PlainGhcException where
showsPrec _ e = showPlainGhcException e
-- | Short usage information to display when we are given the wrong cmd line arguments.
short_usage :: String
short_usage = "Usage: For basic information, try the `--help' option."
-- | Append a description of the given exception to this string.
showPlainGhcException :: PlainGhcException -> ShowS
showPlainGhcException =
\case
PlainSignal n -> showString "signal: " . shows n
PlainUsageError str -> showString str . showChar '\n' . showString short_usage
PlainCmdLineError str -> showString str
PlainPanic s -> panicMsg (showString s)
PlainSorry s -> sorryMsg (showString s)
PlainInstallationError str -> showString str
PlainProgramError str -> showString str
where
sorryMsg :: ShowS -> ShowS
sorryMsg s =
showString "sorry! (unimplemented feature or known bug)\n"
. showString (" GHC version " ++ cProjectVersion ++ ":\n\t")
. s . showString "\n"
panicMsg :: ShowS -> ShowS
panicMsg s =
showString "panic! (the 'impossible' happened)\n"
. showString (" GHC version " ++ cProjectVersion ++ ":\n\t")
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
throwPlainGhcException :: PlainGhcException -> a
throwPlainGhcException = Exception.throw
-- | Panics and asserts.
panic, sorry, pgmError :: HasCallStack => String -> a
panic x = unsafeDupablePerformIO $ do
stack <- ccsToStrings =<< getCurrentCCS x
let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack)
if null stack
then throwPlainGhcException (PlainPanic (x ++ '\n' : doc))
else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))
sorry x = throwPlainGhcException (PlainSorry x)
pgmError x = throwPlainGhcException (PlainProgramError x)
cmdLineError :: String -> a
cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
cmdLineErrorIO :: String -> IO a
cmdLineErrorIO x = do
stack <- ccsToStrings =<< getCurrentCCS x
if null stack
then throwPlainGhcException (PlainCmdLineError x)
else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))
-- | Throw a failed assertion exception for a given filename and line number.
assertPanic :: String -> Int -> a
assertPanic file line =
Exception.throw (Exception.AssertionFailed
("ASSERT failed! file " ++ file ++ ", line " ++ show line))
assertPanic' :: HasCallStack => a
assertPanic' =
let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack)
in
Exception.throw (Exception.AssertionFailed
("ASSERT failed!\n"
++ withFrozenCallStack doc))
assert :: HasCallStack => Bool -> a -> a
{-# INLINE assert #-}
assert cond a =
if debugIsOn && not cond
then withFrozenCallStack assertPanic'
else a
massert :: (HasCallStack, Applicative m) => Bool -> m ()
{-# INLINE massert #-}
massert cond = withFrozenCallStack (assert cond (pure ()))
assertM :: (HasCallStack, Monad m) => m Bool -> m ()
{-# INLINE assertM #-}
assertM mcond = withFrozenCallStack (mcond >>= massert)
|
