%
% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 1992-2000
%
Defines basic functions for printing error messages.
It's hard to put these functions anywhere else without causing
some unnecessary loops in the module dependency graph.
\begin{code}
module Panic (
GhcException(..), showGhcException, throwGhcException, handleGhcException,
ghcError, progName,
pgmError,
panic, sorry, panicFastInt, assertPanic, trace,
Exception.Exception(..), showException, try, tryMost, throwTo,
installSignalHandlers, interruptTargetThread
) where
#include "HsVersions.h"
import Config
import FastTypes
import Exception
import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
myThreadId )
import Data.Dynamic
import Debug.Trace ( trace )
import System.IO.Unsafe ( unsafePerformIO )
import System.Exit
import System.Environment
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
#endif
data GhcException
= PhaseFailed String
ExitCode
| Signal Int
| UsageError String
| CmdLineError String
| Panic String
| Sorry String
| InstallationError String
| ProgramError String
deriving Eq
instance Exception GhcException
instance Show GhcException where
showsPrec _ e@(ProgramError _) = showGhcException e
showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
showsPrec _ e = showString progName . showString ": " . showGhcException e
instance Typeable GhcException where
typeOf _ = mkTyConApp ghcExceptionTc []
progName :: String
progName = unsafePerformIO (getProgName)
short_usage :: String
short_usage = "Usage: For basic information, try the `--help' option."
showException :: Exception e => e -> String
showException = show
showGhcException :: GhcException -> String -> String
showGhcException exception
= case exception of
UsageError str
-> showString str . showChar '\n' . showString short_usage
PhaseFailed phase code
-> showString "phase `" . showString phase .
showString "' failed (exitcode = " . shows (int_code code) .
showString ")"
CmdLineError str -> showString str
ProgramError str -> showString str
InstallationError str -> showString str
Signal n -> showString "signal: " . shows n
Panic s
-> showString $
"panic! (the 'impossible' happened)\n"
++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
++ s ++ "\n\n"
++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n"
Sorry s
-> showString $
"sorry! (unimplemented feature or known bug)\n"
++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
++ s ++ "\n"
where int_code code =
case code of
ExitSuccess -> (0::Int)
ExitFailure x -> x
ghcError :: GhcException -> a
ghcError e = Exception.throw e
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
ghcExceptionTc :: TyCon
ghcExceptionTc = mkTyCon "GhcException"
panic, sorry, pgmError :: String -> a
panic x = throwGhcException (Panic x)
sorry x = throwGhcException (Sorry x)
pgmError x = throwGhcException (ProgramError x)
panicFastInt :: String -> FastInt
panicFastInt s = case (panic s) of () -> _ILIT(0)
assertPanic :: String -> Int -> a
assertPanic file line =
Exception.throw (Exception.AssertionFailed
("ASSERT failed! file " ++ file ++ ", line " ++ show line))
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)
installSignalHandlers :: IO ()
installSignalHandlers = do
main_thread <- myThreadId
modifyMVar_ interruptTargetThread (return . (main_thread :))
let
interrupt_exn = (toException UserInterrupt)
interrupt = do
withMVar interruptTargetThread $ \targets ->
case targets of
[] -> return ()
(thread:_) -> throwTo thread interrupt_exn
#if !defined(mingw32_HOST_OS)
_ <- installHandler sigQUIT (Catch interrupt) Nothing
_ <- installHandler sigINT (Catch interrupt) Nothing
let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
_ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing
_ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing
return ()
#else
let sig_handler ControlC = interrupt
sig_handler Break = interrupt
sig_handler _ = return ()
_ <- installHandler (Catch sig_handler)
return ()
#endif
interruptTargetThread :: MVar [ThreadId]
interruptTargetThread = unsafePerformIO (newMVar [])
\end{code}