ghc/compiler/utils/Panic.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-2000
   3 %
   4 \section{Panic error messages}
   5
   6 Defines basic funtions for printing error messages.
   7
   8 It's hard to put these functions anywhere else without causing
   9 some unnecessary loops in the module dependency graph.
  10
  11 \begin{code}
  12 module Panic
  13    (
  14      GhcException(..), showGhcException, ghcError, progName,
  15      pgmError,
  16
  17      panic, panic#, assertPanic, trace,
  18
  19      Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
  20      catchJust, ioErrors, throwTo,
  21
  22      installSignalHandlers,
  23    ) where
  24
  25 #include "HsVersions.h"
  26
  27 import Config
  28 import FastTypes
  29
  30 #ifndef mingw32_HOST_OS
  31 # if __GLASGOW_HASKELL__ > 504
  32 import System.Posix.Signals
  33 # else
  34 import Posix            ( Handler(Catch), installHandler, sigINT, sigQUIT )
  35 # endif /* GHC > 504 */
  36 #endif /* mingw32_HOST_OS */
  37
  38 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 603
  39 import GHC.ConsoleHandler
  40 #endif
  41
  42 # if __GLASGOW_HASKELL__ < 500
  43 import EXCEPTION        ( raiseInThread )
  44 # else
  45 import EXCEPTION        ( throwTo )
  46 # endif /* GHC < 500 */
  47
  48 #if __GLASGOW_HASKELL__ > 408
  49 import EXCEPTION        ( catchJust, tryJust, ioErrors )
  50 #endif
  51
  52 import CONCURRENT       ( myThreadId )
  53 import DYNAMIC
  54 import qualified EXCEPTION as Exception
  55 import TRACE            ( trace )
  56 import UNSAFE_IO        ( unsafePerformIO )
  57 import IO               ( isUserError )
  58
  59 import System
  60 \end{code}
  61
  62 GHC's own exception type.
  63
  64 \begin{code}
  65 ghcError :: GhcException -> a
  66 ghcError e = Exception.throwDyn e
  67
  68 -- error messages all take the form
  69 --
  70 --      <location>: <error>
  71 --
  72 -- If the location is on the command line, or in GHC itself, then
  73 -- <location>="ghc".  All of the error types below correspond to
  74 -- a <location> of "ghc", except for ProgramError (where the string is
  75 -- assumed to contain a location already, so we don't print one).
  76
  77 data GhcException
  78   = PhaseFailed String          -- name of phase
  79                 ExitCode        -- an external phase (eg. cpp) failed
  80   | Interrupted                 -- someone pressed ^C
  81   | UsageError String           -- prints the short usage msg after the error
  82   | CmdLineError String         -- cmdline prob, but doesn't print usage
  83   | Panic String                -- the `impossible' happened
  84   | InstallationError String    -- an installation problem
  85   | ProgramError String         -- error in the user's code, probably
  86   deriving Eq
  87
  88 progName = unsafePerformIO (getProgName)
  89 {-# NOINLINE progName #-}
  90
  91 short_usage = "Usage: For basic information, try the `--help' option."
  92
  93 showException :: Exception.Exception -> String
  94 -- Show expected dynamic exceptions specially
  95 showException (Exception.DynException d) | Just e <- fromDynamic d
  96                                          = show (e::GhcException)
  97 showException other_exn                  = show other_exn
  98
  99 instance Show GhcException where
 100   showsPrec _ e@(ProgramError _) = showGhcException e
 101   showsPrec _ e = showString progName . showString ": " . showGhcException e
 102
 103 showGhcException (UsageError str)
 104    = showString str . showChar '\n' . showString short_usage
 105 showGhcException (PhaseFailed phase code)
 106    = showString "phase `" . showString phase .
 107      showString "' failed (exitcode = " . shows int_code .
 108      showString ")"
 109   where
 110     int_code =
 111       case code of
 112         ExitSuccess   -> (0::Int)
 113         ExitFailure x -> x
 114 showGhcException (CmdLineError str)
 115    = showString str
 116 showGhcException (ProgramError str)
 117    = showString str
 118 showGhcException (InstallationError str)
 119    = showString str
 120 showGhcException (Interrupted)
 121    = showString "interrupted"
 122 showGhcException (Panic s)
 123    = showString ("panic! (the `impossible' happened, GHC version "
 124                  ++ cProjectVersion ++ "):\n\t"
 125                  ++ s ++ "\n\n"
 126                  ++ "Please report it as a compiler bug "
 127                  ++ "to glasgow-haskell-bugs@haskell.org,\n"
 128                  ++ "or http://sourceforge.net/projects/ghc/.\n\n")
 129
 130 #if __GLASGOW_HASKELL__ < 603
 131 myMkTyConApp = mkAppTy
 132 #else
 133 myMkTyConApp = mkTyConApp
 134 #endif
 135
 136 ghcExceptionTc = mkTyCon "GhcException"
 137 {-# NOINLINE ghcExceptionTc #-}
 138 instance Typeable GhcException where
 139   typeOf _ = myMkTyConApp ghcExceptionTc []
 140 \end{code}
 141
 142 Panics and asserts.
 143
 144 \begin{code}
 145 panic, pgmError :: String -> a
 146 panic    x = Exception.throwDyn (Panic x)
 147 pgmError x = Exception.throwDyn (ProgramError x)
 148
 149 --  #-versions because panic can't return an unboxed int, and that's
 150 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 151 -- No, man -- Too Beautiful! (Will)
 152
 153 panic# :: String -> FastInt
 154 panic# s = case (panic s) of () -> _ILIT 0
 155
 156 assertPanic :: String -> Int -> a
 157 assertPanic file line =
 158   Exception.throw (Exception.AssertionFailed
 159            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 160 \end{code}
 161
 162 \begin{code}
 163 -- | tryMost is like try, but passes through Interrupted and Panic
 164 -- exceptions.  Used when we want soft failures when reading interface
 165 -- files, for example.
 166
 167 tryMost :: IO a -> IO (Either Exception.Exception a)
 168 tryMost action = do r <- try action; filter r
 169   where
 170    filter (Left e@(Exception.DynException d))
 171             | Just ghc_ex <- fromDynamic d
 172                 = case ghc_ex of
 173                     Interrupted -> Exception.throw e
 174                     Panic _     -> Exception.throw e
 175                     _other      -> return (Left e)
 176    filter other
 177      = return other
 178
 179 -- | tryUser is like try, but catches only UserErrors.
 180 -- These are the ones that are thrown by the TcRn monad
 181 -- to signal an error in the program being compiled
 182 tryUser :: IO a -> IO (Either Exception.Exception a)
 183 tryUser action = tryJust tc_errors action
 184   where
 185 #if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500
 186         tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
 187 #elif __GLASGOW_HASKELL__ == 502
 188         tc_errors e@(UserError _) = Just e
 189 #else
 190         tc_errors e@(Exception.IOException ioe) | isUserError e = Just e
 191 #endif
 192         tc_errors _other = Nothing
 193 \end{code}
 194
 195 Compatibility stuff:
 196
 197 \begin{code}
 198 #if __GLASGOW_HASKELL__ <= 408
 199 try = Exception.tryAllIO
 200 #else
 201 try = Exception.try
 202 #endif
 203
 204 #if __GLASGOW_HASKELL__ <= 408
 205 catchJust = Exception.catchIO
 206 tryJust   = Exception.tryIO
 207 ioErrors  = Exception.justIoErrors
 208 throwTo   = Exception.raiseInThread
 209 #endif
 210 \end{code}
 211
 212 Standard signal handlers for catching ^C, which just throw an
 213 exception in the main thread.  NOTE: must be called from the main
 214 thread.
 215
 216 \begin{code}
 217 installSignalHandlers :: IO ()
 218 installSignalHandlers = do
 219   main_thread <- myThreadId
 220   let
 221       interrupt_exn = Exception.DynException (toDyn Interrupted)
 222       interrupt = throwTo main_thread interrupt_exn
 223   --
 224 #if !defined(mingw32_HOST_OS)
 225   installHandler sigQUIT (Catch interrupt) Nothing
 226   installHandler sigINT  (Catch interrupt) Nothing
 227   return ()
 228 #elif __GLASGOW_HASKELL__ >= 603
 229   -- GHC 6.3+ has support for console events on Windows
 230   -- NOTE: running GHCi under a bash shell for some reason requires
 231   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 232   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 233   -- why --SDM 17/12/2004
 234   let sig_handler ControlC = interrupt
 235       sig_handler Break    = interrupt
 236       sig_handler _        = return ()
 237
 238   installHandler (Catch sig_handler)
 239   return ()
 240 #else
 241   return () -- nothing
 242 #endif
 243 \end{code}