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