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