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