module Panic (
GhcException(..), showGhcException,
throwGhcException, throwGhcExceptionIO,
handleGhcException,
PlainPanic.progName,
pgmError,
panic, sorry, assertPanic, trace,
panicDoc, sorryDoc, pgmErrorDoc,
cmdLineError, cmdLineErrorIO,
Exception.Exception(..), showException, safeShowException,
try, tryMost, throwTo,
withSignalHandlers,
) where
import GhcPrelude
import Outputable (SDoc, showSDocUnsafe)
import PlainPanic
import Exception
import Control.Monad.IO.Class
import Control.Concurrent
import Data.Typeable ( cast )
import Debug.Trace ( trace )
import System.IO.Unsafe
#if !defined(mingw32_HOST_OS)
import System.Posix.Signals as S
#endif
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler as S
#endif
import System.Mem.Weak ( deRefWeak )
data GhcException
= Signal Int
| UsageError String
| CmdLineError String
| Panic String
| PprPanic String SDoc
| Sorry String
| PprSorry String SDoc
| InstallationError String
| ProgramError String
| PprProgramError String SDoc
instance Exception GhcException where
fromException (SomeException e)
| Just ge <- cast e = Just ge
| Just pge <- cast e = Just $
case pge of
PlainSignal n -> Signal n
PlainUsageError str -> UsageError str
PlainCmdLineError str -> CmdLineError str
PlainPanic str -> Panic str
PlainSorry str -> Sorry str
PlainInstallationError str -> InstallationError str
PlainProgramError str -> ProgramError str
| otherwise = Nothing
instance Show GhcException where
showsPrec _ e@(ProgramError _) = showGhcException e
showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
showsPrec _ e = showString progName . showString ": " . showGhcException e
showException :: Exception e => e -> String
showException = show
safeShowException :: Exception e => e -> IO String
safeShowException e = do
r <- try (return $! forceList (showException e))
case r of
Right msg -> return msg
Left e' -> safeShowException (e' :: SomeException)
where
forceList [] = []
forceList xs@(x : xt) = x `seq` forceList xt `seq` xs
showGhcException :: GhcException -> ShowS
showGhcException = showPlainGhcException . \case
Signal n -> PlainSignal n
UsageError str -> PlainUsageError str
CmdLineError str -> PlainCmdLineError str
Panic str -> PlainPanic str
Sorry str -> PlainSorry str
InstallationError str -> PlainInstallationError str
ProgramError str -> PlainProgramError str
PprPanic str sdoc -> PlainPanic $
concat [str, "\n\n", showSDocUnsafe sdoc]
PprSorry str sdoc -> PlainProgramError $
concat [str, "\n\n", showSDocUnsafe sdoc]
PprProgramError str sdoc -> PlainProgramError $
concat [str, "\n\n", showSDocUnsafe sdoc]
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw
throwGhcExceptionIO :: GhcException -> IO a
throwGhcExceptionIO = Exception.throwIO
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
panicDoc x doc = throwGhcException (PprPanic x doc)
sorryDoc x doc = throwGhcException (PprSorry x doc)
pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
tryMost :: IO a -> IO (Either SomeException a)
tryMost action = do r <- try action
case r of
Left se ->
case fromException se of
Just (Signal _) -> throwIO se
Just (Panic _) -> throwIO se
Just _ -> return (Left se)
Nothing ->
case fromException se of
Just (_ :: IOException) ->
return (Left se)
Nothing -> throwIO se
Right v -> return (Right v)
#if !defined(mingw32_HOST_OS)
signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler
,S.Handler,S.Handler))
#else
signalHandlersRefCount :: MVar (Word, Maybe S.Handler)
#endif
signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)
withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a
withSignalHandlers act = do
main_thread <- liftIO myThreadId
wtid <- liftIO (mkWeakThreadId main_thread)
let
interrupt = do
r <- deRefWeak wtid
case r of
Nothing -> return ()
Just t -> throwTo t UserInterrupt
#if !defined(mingw32_HOST_OS)
let installHandlers = do
let installHandler' a b = installHandler a b Nothing
hdlQUIT <- installHandler' sigQUIT (Catch interrupt)
hdlINT <- installHandler' sigINT (Catch interrupt)
let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP))
hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM))
return (hdlQUIT,hdlINT,hdlHUP,hdlTERM)
let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do
_ <- installHandler sigQUIT hdlQUIT Nothing
_ <- installHandler sigINT hdlINT Nothing
_ <- installHandler sigHUP hdlHUP Nothing
_ <- installHandler sigTERM hdlTERM Nothing
return ()
#else
let sig_handler ControlC = interrupt
sig_handler Break = interrupt
sig_handler _ = return ()
let installHandlers = installHandler (Catch sig_handler)
let uninstallHandlers = installHandler
#endif
let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
(0,Nothing) -> do
hdls <- installHandlers
return (1,Just hdls)
(c,oldHandlers) -> return (c+1,oldHandlers)
let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
(1,Just hdls) -> do
_ <- uninstallHandlers hdls
return (0,Nothing)
(c,oldHandlers) -> return (c1,oldHandlers)
mayInstallHandlers
act `gfinally` mayUninstallHandlers