1{-
2(c) The University of Glasgow 2006
3(c) The GRASP Project, Glasgow University, 1992-2000
4
5-}
6
7{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
8
9-- | Defines basic functions for printing error messages.
10--
11-- It's hard to put these functions anywhere else without causing
12-- some unnecessary loops in the module dependency graph.
13module GHC.Utils.Panic
14   ( GhcException(..)
15   , showGhcException
16   , showGhcExceptionUnsafe
17   , throwGhcException
18   , throwGhcExceptionIO
19   , handleGhcException
20
21   , GHC.Utils.Panic.Plain.progName
22   , pgmError
23   , panic
24   , pprPanic
25   , assertPanic
26   , assertPprPanic
27   , sorry
28   , trace
29   , panicDoc
30   , sorryDoc
31   , pgmErrorDoc
32   , cmdLineError
33   , cmdLineErrorIO
34   , callStackDoc
35
36   , Exception.Exception(..)
37   , showException
38   , safeShowException
39   , try
40   , tryMost
41   , throwTo
42   , withSignalHandlers
43   )
44where
45
46import GHC.Prelude
47import GHC.Stack
48
49import GHC.Utils.Outputable
50import GHC.Utils.Panic.Plain
51
52import GHC.Utils.Exception as Exception
53
54import Control.Monad.IO.Class
55import qualified Control.Monad.Catch as MC
56import Control.Concurrent
57import Data.Typeable      ( cast )
58import Debug.Trace        ( trace )
59import System.IO.Unsafe
60
61#if !defined(mingw32_HOST_OS)
62import System.Posix.Signals as S
63#endif
64
65#if defined(mingw32_HOST_OS)
66import GHC.ConsoleHandler as S
67#endif
68
69import System.Mem.Weak  ( deRefWeak )
70
71-- | GHC's own exception type
72--   error messages all take the form:
73--
74--  @
75--      \<location>: \<error>
76--  @
77--
78--   If the location is on the command line, or in GHC itself, then
79--   \<location>="ghc".  All of the error types below correspond to
80--   a \<location> of "ghc", except for ProgramError (where the string is
81--  assumed to contain a location already, so we don't print one).
82
83data GhcException
84  -- | Some other fatal signal (SIGHUP,SIGTERM)
85  = Signal Int
86
87  -- | Prints the short usage msg after the error
88  | UsageError   String
89
90  -- | A problem with the command line arguments, but don't print usage.
91  | CmdLineError String
92
93  -- | The 'impossible' happened.
94  | Panic        String
95  | PprPanic     String SDoc
96
97  -- | The user tickled something that's known not to work yet,
98  --   but we're not counting it as a bug.
99  | Sorry        String
100  | PprSorry     String SDoc
101
102  -- | An installation problem.
103  | InstallationError String
104
105  -- | An error in the user's code, probably.
106  | ProgramError    String
107  | PprProgramError String SDoc
108
109instance Exception GhcException where
110  fromException (SomeException e)
111    | Just ge <- cast e = Just ge
112    | Just pge <- cast e = Just $
113        case pge of
114          PlainSignal n -> Signal n
115          PlainUsageError str -> UsageError str
116          PlainCmdLineError str -> CmdLineError str
117          PlainPanic str -> Panic str
118          PlainSorry str -> Sorry str
119          PlainInstallationError str -> InstallationError str
120          PlainProgramError str -> ProgramError str
121    | otherwise = Nothing
122
123instance Show GhcException where
124  showsPrec _ e@(ProgramError _) = showGhcExceptionUnsafe e
125  showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcExceptionUnsafe e
126  showsPrec _ e = showString progName . showString ": " . showGhcExceptionUnsafe e
127
128-- | Show an exception as a string.
129showException :: Exception e => e -> String
130showException = show
131
132-- | Show an exception which can possibly throw other exceptions.
133-- Used when displaying exception thrown within TH code.
134safeShowException :: Exception e => e -> IO String
135safeShowException 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.
149showGhcExceptionUnsafe :: GhcException -> ShowS
150showGhcExceptionUnsafe = showGhcException defaultSDocContext
151
152-- | Append a description of the given exception to this string.
153showGhcException :: SDocContext -> GhcException -> ShowS
154showGhcException 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
170throwGhcException :: GhcException -> a
171throwGhcException = Exception.throw
172
173throwGhcExceptionIO :: GhcException -> IO a
174throwGhcExceptionIO = Exception.throwIO
175
176handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
177handleGhcException = MC.handle
178
179-- | Throw an exception saying "bug in GHC" with a callstack
180pprPanic :: HasCallStack => String -> SDoc -> a
181pprPanic s doc = panicDoc s (doc $$ callStackDoc)
182
183-- | Throw an exception saying "bug in GHC"
184panicDoc :: String -> SDoc -> a
185panicDoc x doc = throwGhcException (PprPanic x doc)
186
187-- | Throw an exception saying "this isn't finished yet"
188sorryDoc :: String -> SDoc -> a
189sorryDoc x doc = throwGhcException (PprSorry x doc)
190
191-- | Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
192pgmErrorDoc :: String -> SDoc -> a
193pgmErrorDoc 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
198tryMost :: IO a -> IO (Either SomeException a)
199tryMost 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)
220signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler
221                                            ,S.Handler,S.Handler))
222#else
223signalHandlersRefCount :: MVar (Word, Maybe S.Handler)
224#endif
225signalHandlersRefCount = 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.
230withSignalHandlers :: ExceptionMonad m => m a -> m a
231withSignalHandlers 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
291callStackDoc :: HasCallStack => SDoc
292callStackDoc =
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
298assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a
299assertPprPanic _file _line msg
300  = pprPanic "ASSERT failed!" msg
301