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
|
{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
-- | Defines a simple exception type and utilities to throw it. The
-- 'PlainGhcException' type is a subset of the 'Panic.GhcException'
-- type. It omits the exception constructors that involve
-- pretty-printing via 'Outputable.SDoc'.
--
-- There are two reasons for this:
--
-- 1. To avoid import cycles / use of boot files. "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
, progName
) where
#include "HsVersions.h"
import GHC.Settings.Config
import GHC.Utils.Exception as Exception
import GHC.Stack
import GHC.Prelude
import System.Environment
import System.IO.Unsafe
-- | This type is very similar to 'Panic.GhcException', but it omits
-- the constructors that involve pretty-printing via
-- 'Outputable.SDoc'. Due to the implementation of 'fromException'
-- for 'Panic.GhcException', this type can be caught as a
-- 'Panic.GhcException'.
--
-- Note that this should only be used for throwing exceptions, not for
-- catching, as '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@(PlainProgramError _) = showPlainGhcException e
showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e
showsPrec _ e = showString progName . showString ": " . showPlainGhcException e
-- | The name of this GHC.
progName :: String
progName = unsafePerformIO (getProgName)
{-# NOINLINE progName #-}
-- | 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 :: String -> a
panic x = unsafeDupablePerformIO $ do
stack <- ccsToStrings =<< getCurrentCCS x
if null stack
then throwPlainGhcException (PlainPanic x)
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))
|
