never executed always true always false
1 {-# LANGUAGE ScopedTypeVariables, LambdaCase #-}
2
3 -- | Defines a simple exception type and utilities to throw it. The
4 -- 'PlainGhcException' type is a subset of the 'GHC.Utils.Panic.GhcException'
5 -- type. It omits the exception constructors that involve
6 -- pretty-printing via 'GHC.Utils.Outputable.SDoc'.
7 --
8 -- There are two reasons for this:
9 --
10 -- 1. To avoid import cycles / use of boot files. "GHC.Utils.Outputable" has
11 -- many transitive dependencies. To throw exceptions from these
12 -- modules, the functions here can be used without introducing import
13 -- cycles.
14 --
15 -- 2. To reduce the number of modules that need to be compiled to
16 -- object code when loading GHC into GHCi. See #13101
17 module GHC.Utils.Panic.Plain
18 ( PlainGhcException(..)
19 , showPlainGhcException
20
21 , panic, sorry, pgmError
22 , cmdLineError, cmdLineErrorIO
23 , assertPanic
24 , assert, assertM, massert
25 ) where
26
27 import GHC.Settings.Config
28 import GHC.Utils.Constants
29 import GHC.Utils.Exception as Exception
30 import GHC.Stack
31 import GHC.Prelude
32 import System.IO.Unsafe
33
34 -- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits
35 -- the constructors that involve pretty-printing via
36 -- 'GHC.Utils.Outputable.SDoc'. Due to the implementation of 'fromException'
37 -- for 'GHC.Utils.Panic.GhcException', this type can be caught as a
38 -- 'GHC.Utils.Panic.GhcException'.
39 --
40 -- Note that this should only be used for throwing exceptions, not for
41 -- catching, as 'GHC.Utils.Panic.GhcException' will not be converted to this
42 -- type when catching.
43 data PlainGhcException
44 -- | Some other fatal signal (SIGHUP,SIGTERM)
45 = PlainSignal Int
46
47 -- | Prints the short usage msg after the error
48 | PlainUsageError String
49
50 -- | A problem with the command line arguments, but don't print usage.
51 | PlainCmdLineError String
52
53 -- | The 'impossible' happened.
54 | PlainPanic String
55
56 -- | The user tickled something that's known not to work yet,
57 -- but we're not counting it as a bug.
58 | PlainSorry String
59
60 -- | An installation problem.
61 | PlainInstallationError String
62
63 -- | An error in the user's code, probably.
64 | PlainProgramError String
65
66 instance Exception PlainGhcException
67
68 instance Show PlainGhcException where
69 showsPrec _ e = showPlainGhcException e
70
71 -- | Short usage information to display when we are given the wrong cmd line arguments.
72 short_usage :: String
73 short_usage = "Usage: For basic information, try the `--help' option."
74
75 -- | Append a description of the given exception to this string.
76 showPlainGhcException :: PlainGhcException -> ShowS
77 showPlainGhcException =
78 \case
79 PlainSignal n -> showString "signal: " . shows n
80 PlainUsageError str -> showString str . showChar '\n' . showString short_usage
81 PlainCmdLineError str -> showString str
82 PlainPanic s -> panicMsg (showString s)
83 PlainSorry s -> sorryMsg (showString s)
84 PlainInstallationError str -> showString str
85 PlainProgramError str -> showString str
86 where
87 sorryMsg :: ShowS -> ShowS
88 sorryMsg s =
89 showString "sorry! (unimplemented feature or known bug)\n"
90 . showString (" GHC version " ++ cProjectVersion ++ ":\n\t")
91 . s . showString "\n"
92
93 panicMsg :: ShowS -> ShowS
94 panicMsg s =
95 showString "panic! (the 'impossible' happened)\n"
96 . showString (" GHC version " ++ cProjectVersion ++ ":\n\t")
97 . s . showString "\n\n"
98 . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
99
100 throwPlainGhcException :: PlainGhcException -> a
101 throwPlainGhcException = Exception.throw
102
103 -- | Panics and asserts.
104 panic, sorry, pgmError :: String -> a
105 panic x = unsafeDupablePerformIO $ do
106 stack <- ccsToStrings =<< getCurrentCCS x
107 if null stack
108 then throwPlainGhcException (PlainPanic x)
109 else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))
110
111 sorry x = throwPlainGhcException (PlainSorry x)
112 pgmError x = throwPlainGhcException (PlainProgramError x)
113
114 cmdLineError :: String -> a
115 cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
116
117 cmdLineErrorIO :: String -> IO a
118 cmdLineErrorIO x = do
119 stack <- ccsToStrings =<< getCurrentCCS x
120 if null stack
121 then throwPlainGhcException (PlainCmdLineError x)
122 else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))
123
124 -- | Throw a failed assertion exception for a given filename and line number.
125 assertPanic :: String -> Int -> a
126 assertPanic file line =
127 Exception.throw (Exception.AssertionFailed
128 ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
129
130
131 assertPanic' :: HasCallStack => a
132 assertPanic' =
133 let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack)
134 in
135 Exception.throw (Exception.AssertionFailed
136 ("ASSERT failed!\n"
137 ++ withFrozenCallStack doc))
138
139 assert :: HasCallStack => Bool -> a -> a
140 {-# INLINE assert #-}
141 assert cond a =
142 if debugIsOn && not cond
143 then withFrozenCallStack assertPanic'
144 else a
145
146 massert :: (HasCallStack, Applicative m) => Bool -> m ()
147 {-# INLINE massert #-}
148 massert cond = withFrozenCallStack (assert cond (pure ()))
149
150 assertM :: (HasCallStack, Monad m) => m Bool -> m ()
151 {-# INLINE assertM #-}
152 assertM mcond = withFrozenCallStack (mcond >>= massert)