% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 1992-2000
%
-
-Defines basic funtions for printing error messages.
+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
- (
+module Panic (
GhcException(..), showGhcException, throwGhcException, handleGhcException,
ghcError, progName,
pgmError,
Exception.Exception(..), showException, try, tryMost, throwTo,
installSignalHandlers, interruptTargetThread
- ) where
-
+) where
#include "HsVersions.h"
import Config
import FastTypes
-
-#ifndef mingw32_HOST_OS
-import System.Posix.Signals
-#endif /* mingw32_HOST_OS */
-
-#if defined(mingw32_HOST_OS)
-import GHC.ConsoleHandler
-#endif
-
import Exception
import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
myThreadId )
import Data.Dynamic
-import Debug.Trace ( trace )
-import System.IO.Unsafe ( unsafePerformIO )
+import Debug.Trace ( trace )
+import System.IO.Unsafe ( unsafePerformIO )
import System.Exit
import System.Environment
-\end{code}
-GHC's own exception type.
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+#endif
+
+#if defined(mingw32_HOST_OS)
+import GHC.ConsoleHandler
+#endif
-\begin{code}
-ghcError :: GhcException -> a
-ghcError e = Exception.throw e
--- error messages all take the form
+-- | GHC's own exception type
+-- error messages all take the form:
--
+-- @
-- <location>: <error>
---
--- If the location is on the command line, or in GHC itself, then
--- <location>="ghc". All of the error types below correspond to
--- a <location> of "ghc", except for ProgramError (where the string is
--- assumed to contain a location already, so we don't print one).
+-- @
+--
+-- If the location is on the command line, or in GHC itself, then
+-- <location>="ghc". All of the error types below correspond to
+-- a <location> of "ghc", except for ProgramError (where the string is
+-- assumed to contain a location already, so we don't print one).
data GhcException
= PhaseFailed String -- name of phase
ExitCode -- an external phase (eg. cpp) failed
- | Signal Int -- some other fatal signal (SIGHUP,SIGTERM)
- | UsageError String -- prints the short usage msg after the error
- | CmdLineError String -- cmdline prob, but doesn't print usage
- | Panic String -- the `impossible' happened
- | Sorry String -- the user tickled something that's known not to work yet,
- -- and we're not counting it as a bug.
- | InstallationError String -- an installation problem
- | ProgramError String -- error in the user's code, probably
+
+ -- | Some other fatal signal (SIGHUP,SIGTERM)
+ | Signal Int
+
+ -- | Prints the short usage msg after the error
+ | UsageError String
+
+ -- | A problem with the command line arguments, but don't print usage.
+ | CmdLineError String
+
+ -- | The 'impossible' happened.
+ | Panic String
+
+ -- | The user tickled something that's known not to work yet,
+ -- but we're not counting it as a bug.
+ | Sorry String
+
+ -- | An installation problem.
+ | InstallationError String
+
+ -- | An error in the user's code, probably.
+ | 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 []
+
+
+-- | The name of this GHC.
progName :: String
progName = unsafePerformIO (getProgName)
{-# NOINLINE progName #-}
+
+-- | Short usage information to display when we are given the wrong cmd line arguments.
short_usage :: String
short_usage = "Usage: For basic information, try the `--help' option."
+
+-- | Show an exception as a string.
showException :: Exception e => e -> String
showException = show
-instance Show GhcException where
- showsPrec _ e@(ProgramError _) = showGhcException e
- showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
- showsPrec _ e = showString progName . showString ": " . showGhcException e
+-- | Append a description of the given exception to this string.
showGhcException :: GhcException -> String -> String
-showGhcException (UsageError str)
- = showString str . showChar '\n' . showString short_usage
-showGhcException (PhaseFailed phase code)
- = showString "phase `" . showString phase .
- showString "' failed (exitcode = " . shows int_code .
- showString ")"
- where
- int_code =
- case code of
- ExitSuccess -> (0::Int)
- ExitFailure x -> x
-showGhcException (CmdLineError str)
- = showString str
-showGhcException (ProgramError str)
- = showString str
-showGhcException (InstallationError str)
- = showString str
-showGhcException (Signal n)
- = showString "signal: " . shows n
-showGhcException (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")
-showGhcException (Sorry s)
- = showString ("sorry! (this is work in progress)\n"
+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! (this is work in progress)\n"
++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
- ++ s ++ "\n")
+ ++ s ++ "\n"
+ where int_code code =
+ case code of
+ ExitSuccess -> (0::Int)
+ ExitFailure x -> x
+
+
+-- | Alias for `throwGhcException`
+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"
{-# NOINLINE ghcExceptionTc #-}
-instance Typeable GhcException where
- typeOf _ = mkTyConApp ghcExceptionTc []
-\end{code}
-Panics and asserts.
-\begin{code}
+-- | Panics and asserts.
panic, sorry, pgmError :: String -> a
panic x = throwGhcException (Panic x)
sorry x = throwGhcException (Sorry x)
pgmError x = throwGhcException (ProgramError x)
--- #-versions because panic can't return an unboxed int, and that's
--- what TAG_ is with GHC at the moment. Ugh. (Simon)
--- No, man -- Too Beautiful! (Will)
+-- | Panic while pretending to return an unboxed int.
+-- You can't use the regular panic functions in expressions
+-- producing unboxed ints because they have the wrong kind.
panicFastInt :: String -> FastInt
panicFastInt s = case (panic s) of () -> _ILIT(0)
+
+-- | Throw an failed assertion exception for a given filename and line number.
assertPanic :: String -> Int -> a
assertPanic file line =
Exception.throw (Exception.AssertionFailed
("ASSERT failed! file " ++ file ++ ", line " ++ show line))
-\end{code}
-\begin{code}
--- | tryMost is like try, but passes through UserInterrupt and Panic
--- exceptions. Used when we want soft failures when reading interface
--- files, for example.
--- XXX I'm not entirely sure if this is catching what we really want to catch
+-- | Like try, but pass through UserInterrupt and Panic exceptions.
+-- Used when we want soft failures when reading interface files, for example.
+-- TODO: I'm not entirely sure if this is catching what we really want to catch
tryMost :: IO a -> IO (Either SomeException a)
tryMost action = do r <- try action
case r of
-- Anything else is rethrown
Nothing -> throwIO se
Right v -> return (Right v)
-\end{code}
-Standard signal handlers for catching ^C, which just throw an
-exception in the target thread. The current target thread is
-the thread at the head of the list in the MVar passed to
-installSignalHandlers.
-\begin{code}
+-- | Install standard signal handlers for catching ^C, which just throw an
+-- exception in the target thread. The current target thread is the
+-- thread at the head of the list in the MVar passed to
+-- installSignalHandlers.
installSignalHandlers :: IO ()
installSignalHandlers = do
main_thread <- myThreadId
{-# NOINLINE interruptTargetThread #-}
interruptTargetThread :: MVar [ThreadId]
interruptTargetThread = unsafePerformIO (newMVar [])
+
\end{code}
projects / ghc-hetmet.git / commitdiff