never executed always true always false
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP Project, Glasgow University, 1992-2000
4
5 -}
6
7 {-# LANGUAGE CPP #-}
8 {-# LANGUAGE ScopedTypeVariables, LambdaCase #-}
9
10 -- | Defines basic functions for printing error messages.
11 --
12 -- It's hard to put these functions anywhere else without causing
13 -- some unnecessary loops in the module dependency graph.
14 module GHC.Utils.Panic
15 ( GhcException(..)
16 , showGhcException
17 , showGhcExceptionUnsafe
18 , throwGhcException
19 , throwGhcExceptionIO
20 , handleGhcException
21
22 , pgmError
23 , panic
24 , pprPanic
25 , assertPanic
26 , assertPprPanic
27 , assertPpr
28 , assertPprM
29 , massertPpr
30 , sorry
31 , panicDoc
32 , sorryDoc
33 , pgmErrorDoc
34 , cmdLineError
35 , cmdLineErrorIO
36 , callStackDoc
37
38 , Exception.Exception(..)
39 , showException
40 , safeShowException
41 , try
42 , tryMost
43 , throwTo
44 , withSignalHandlers
45 )
46 where
47
48 import GHC.Prelude
49 import GHC.Stack
50
51 import GHC.Utils.Outputable
52 import GHC.Utils.Panic.Plain
53 import GHC.Utils.Constants
54
55 import GHC.Utils.Exception as Exception
56
57 import Control.Monad.IO.Class
58 import qualified Control.Monad.Catch as MC
59 import Control.Concurrent
60 import Data.Typeable ( cast )
61 import System.IO.Unsafe
62
63 #if !defined(mingw32_HOST_OS)
64 import System.Posix.Signals as S
65 #endif
66
67 #if defined(mingw32_HOST_OS)
68 import GHC.ConsoleHandler as S
69 #endif
70
71 import System.Mem.Weak ( deRefWeak )
72
73 -- | GHC's own exception type
74 -- error messages all take the form:
75 --
76 -- @
77 -- \<location>: \<error>
78 -- @
79 --
80 -- If the location is on the command line, or in GHC itself, then
81 -- \<location>="ghc". All of the error types below correspond to
82 -- a \<location> of "ghc", except for ProgramError (where the string is
83 -- assumed to contain a location already, so we don't print one).
84
85 data GhcException
86 -- | Some other fatal signal (SIGHUP,SIGTERM)
87 = Signal Int
88
89 -- | Prints the short usage msg after the error
90 | UsageError String
91
92 -- | A problem with the command line arguments, but don't print usage.
93 | CmdLineError String
94
95 -- | The 'impossible' happened.
96 | Panic String
97 | PprPanic String SDoc
98
99 -- | The user tickled something that's known not to work yet,
100 -- but we're not counting it as a bug.
101 | Sorry String
102 | PprSorry String SDoc
103
104 -- | An installation problem.
105 | InstallationError String
106
107 -- | An error in the user's code, probably.
108 | ProgramError String
109 | PprProgramError String SDoc
110
111 instance Exception GhcException where
112 fromException (SomeException e)
113 | Just ge <- cast e = Just ge
114 | Just pge <- cast e = Just $
115 case pge of
116 PlainSignal n -> Signal n
117 PlainUsageError str -> UsageError str
118 PlainCmdLineError str -> CmdLineError str
119 PlainPanic str -> Panic str
120 PlainSorry str -> Sorry str
121 PlainInstallationError str -> InstallationError str
122 PlainProgramError str -> ProgramError str
123 | otherwise = Nothing
124
125 instance Show GhcException where
126 showsPrec _ e = showGhcExceptionUnsafe e
127
128 -- | Show an exception as a string.
129 showException :: Exception e => e -> String
130 showException = show
131
132 -- | Show an exception which can possibly throw other exceptions.
133 -- Used when displaying exception thrown within TH code.
134 safeShowException :: Exception e => e -> IO String
135 safeShowException e = do
136 -- ensure the whole error message is evaluated inside try
137 r <- try (return $! forceList (showException e))
138 case r of
139 Right msg -> return msg
140 Left e' -> safeShowException (e' :: SomeException)
141 where
142 forceList [] = []
143 forceList xs@(x : xt) = x `seq` forceList xt `seq` xs
144
145 -- | Append a description of the given exception to this string.
146 --
147 -- Note that this uses 'defaultSDocContext', which doesn't use the options
148 -- set by the user via DynFlags.
149 showGhcExceptionUnsafe :: GhcException -> ShowS
150 showGhcExceptionUnsafe = showGhcException defaultSDocContext
151
152 -- | Append a description of the given exception to this string.
153 showGhcException :: SDocContext -> GhcException -> ShowS
154 showGhcException ctx = showPlainGhcException . \case
155 Signal n -> PlainSignal n
156 UsageError str -> PlainUsageError str
157 CmdLineError str -> PlainCmdLineError str
158 Panic str -> PlainPanic str
159 Sorry str -> PlainSorry str
160 InstallationError str -> PlainInstallationError str
161 ProgramError str -> PlainProgramError str
162
163 PprPanic str sdoc -> PlainPanic $
164 concat [str, "\n\n", renderWithContext ctx sdoc]
165 PprSorry str sdoc -> PlainProgramError $
166 concat [str, "\n\n", renderWithContext ctx sdoc]
167 PprProgramError str sdoc -> PlainProgramError $
168 concat [str, "\n\n", renderWithContext ctx sdoc]
169
170 throwGhcException :: GhcException -> a
171 throwGhcException = Exception.throw
172
173 throwGhcExceptionIO :: GhcException -> IO a
174 throwGhcExceptionIO = Exception.throwIO
175
176 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
177 handleGhcException = MC.handle
178
179 -- | Throw an exception saying "bug in GHC" with a callstack
180 pprPanic :: HasCallStack => String -> SDoc -> a
181 pprPanic s doc = panicDoc s (doc $$ callStackDoc)
182
183 -- | Throw an exception saying "bug in GHC"
184 panicDoc :: String -> SDoc -> a
185 panicDoc x doc = throwGhcException (PprPanic x doc)
186
187 -- | Throw an exception saying "this isn't finished yet"
188 sorryDoc :: String -> SDoc -> a
189 sorryDoc x doc = throwGhcException (PprSorry x doc)
190
191 -- | Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
192 pgmErrorDoc :: String -> SDoc -> a
193 pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
194
195 -- | Like try, but pass through UserInterrupt and Panic exceptions.
196 -- Used when we want soft failures when reading interface files, for example.
197 -- TODO: I'm not entirely sure if this is catching what we really want to catch
198 tryMost :: IO a -> IO (Either SomeException a)
199 tryMost action = do r <- try action
200 case r of
201 Left se ->
202 case fromException se of
203 -- Some GhcException's we rethrow,
204 Just (Signal _) -> throwIO se
205 Just (Panic _) -> throwIO se
206 -- others we return
207 Just _ -> return (Left se)
208 Nothing ->
209 case fromException se of
210 -- All IOExceptions are returned
211 Just (_ :: IOException) ->
212 return (Left se)
213 -- Anything else is rethrown
214 Nothing -> throwIO se
215 Right v -> return (Right v)
216
217 -- | We use reference counting for signal handlers
218 {-# NOINLINE signalHandlersRefCount #-}
219 #if !defined(mingw32_HOST_OS)
220 signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler
221 ,S.Handler,S.Handler))
222 #else
223 signalHandlersRefCount :: MVar (Word, Maybe S.Handler)
224 #endif
225 signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)
226
227
228 -- | Temporarily install standard signal handlers for catching ^C, which just
229 -- throw an exception in the current thread.
230 withSignalHandlers :: ExceptionMonad m => m a -> m a
231 withSignalHandlers act = do
232 main_thread <- liftIO myThreadId
233 wtid <- liftIO (mkWeakThreadId main_thread)
234
235 let
236 interrupt = do
237 r <- deRefWeak wtid
238 case r of
239 Nothing -> return ()
240 Just t -> throwTo t UserInterrupt
241
242 #if !defined(mingw32_HOST_OS)
243 let installHandlers = do
244 let installHandler' a b = installHandler a b Nothing
245 hdlQUIT <- installHandler' sigQUIT (Catch interrupt)
246 hdlINT <- installHandler' sigINT (Catch interrupt)
247 -- see #3656; in the future we should install these automatically for
248 -- all Haskell programs in the same way that we install a ^C handler.
249 let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
250 hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP))
251 hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM))
252 return (hdlQUIT,hdlINT,hdlHUP,hdlTERM)
253
254 let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do
255 _ <- installHandler sigQUIT hdlQUIT Nothing
256 _ <- installHandler sigINT hdlINT Nothing
257 _ <- installHandler sigHUP hdlHUP Nothing
258 _ <- installHandler sigTERM hdlTERM Nothing
259 return ()
260 #else
261 -- GHC 6.3+ has support for console events on Windows
262 -- NOTE: running GHCi under a bash shell for some reason requires
263 -- you to press Ctrl-Break rather than Ctrl-C to provoke
264 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
265 -- why --SDM 17/12/2004
266 let sig_handler ControlC = interrupt
267 sig_handler Break = interrupt
268 sig_handler _ = return ()
269
270 let installHandlers = installHandler (Catch sig_handler)
271 let uninstallHandlers = installHandler -- directly install the old handler
272 #endif
273
274 -- install signal handlers if necessary
275 let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
276 (0,Nothing) -> do
277 hdls <- installHandlers
278 return (1,Just hdls)
279 (c,oldHandlers) -> return (c+1,oldHandlers)
280
281 -- uninstall handlers if necessary
282 let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
283 (1,Just hdls) -> do
284 _ <- uninstallHandlers hdls
285 return (0,Nothing)
286 (c,oldHandlers) -> return (c-1,oldHandlers)
287
288 mayInstallHandlers
289 act `MC.finally` mayUninstallHandlers
290
291 callStackDoc :: HasCallStack => SDoc
292 callStackDoc =
293 hang (text "Call stack:")
294 4 (vcat $ map text $ lines (prettyCallStack callStack))
295
296 -- | Panic with an assertion failure, recording the given file and
297 -- line number. Should typically be accessed with the ASSERT family of macros
298 assertPprPanic :: HasCallStack => SDoc -> a
299 assertPprPanic msg = withFrozenCallStack (pprPanic "ASSERT failed!" msg)
300
301
302 assertPpr :: HasCallStack => Bool -> SDoc -> a -> a
303 {-# INLINE assertPpr #-}
304 assertPpr cond msg a =
305 if debugIsOn && not cond
306 then withFrozenCallStack (assertPprPanic msg)
307 else a
308
309 massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m ()
310 {-# INLINE massertPpr #-}
311 massertPpr cond msg = withFrozenCallStack (assertPpr cond msg (pure ()))
312
313 assertPprM :: (HasCallStack, Monad m) => m Bool -> SDoc -> m ()
314 {-# INLINE assertPprM #-}
315 assertPprM mcond msg = withFrozenCallStack (mcond >>= \cond -> massertPpr cond msg)