2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-2000
6 Defines basic funtions for printing error messages.
8 It's hard to put these functions anywhere else without causing
9 some unnecessary loops in the module dependency graph.
14 GhcException(..), showGhcException, ghcError, progName,
17 panic, panicFastInt, assertPanic, trace,
19 Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
20 catchJust, ioErrors, throwTo,
22 installSignalHandlers, interruptTargetThread
25 -- XXX This define is a bit of a hack, and should be done more nicely
26 #define FAST_STRING_NOT_NEEDED 1
27 #include "HsVersions.h"
32 #ifndef mingw32_HOST_OS
33 import System.Posix.Signals
34 #endif /* mingw32_HOST_OS */
36 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 603
37 import GHC.ConsoleHandler
40 import Control.Exception
41 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
43 import qualified Control.Exception as Exception
44 import Debug.Trace ( trace )
45 import System.IO.Unsafe ( unsafePerformIO )
46 import System.IO.Error ( isUserError )
48 import System.Environment
51 GHC's own exception type.
54 ghcError :: GhcException -> a
55 ghcError e = Exception.throwDyn e
57 -- error messages all take the form
59 -- <location>: <error>
61 -- If the location is on the command line, or in GHC itself, then
62 -- <location>="ghc". All of the error types below correspond to
63 -- a <location> of "ghc", except for ProgramError (where the string is
64 -- assumed to contain a location already, so we don't print one).
67 = PhaseFailed String -- name of phase
68 ExitCode -- an external phase (eg. cpp) failed
69 | Interrupted -- someone pressed ^C
70 | UsageError String -- prints the short usage msg after the error
71 | CmdLineError String -- cmdline prob, but doesn't print usage
72 | Panic String -- the `impossible' happened
73 | InstallationError String -- an installation problem
74 | ProgramError String -- error in the user's code, probably
78 progName = unsafePerformIO (getProgName)
79 {-# NOINLINE progName #-}
82 short_usage = "Usage: For basic information, try the `--help' option."
84 showException :: Exception.Exception -> String
85 -- Show expected dynamic exceptions specially
86 showException (Exception.DynException d) | Just e <- fromDynamic d
87 = show (e::GhcException)
88 showException other_exn = show other_exn
90 instance Show GhcException where
91 showsPrec _ e@(ProgramError _) = showGhcException e
92 showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
93 showsPrec _ e = showString progName . showString ": " . showGhcException e
95 showGhcException :: GhcException -> String -> String
96 showGhcException (UsageError str)
97 = showString str . showChar '\n' . showString short_usage
98 showGhcException (PhaseFailed phase code)
99 = showString "phase `" . showString phase .
100 showString "' failed (exitcode = " . shows int_code .
105 ExitSuccess -> (0::Int)
107 showGhcException (CmdLineError str)
109 showGhcException (ProgramError str)
111 showGhcException (InstallationError str)
113 showGhcException (Interrupted)
114 = showString "interrupted"
115 showGhcException (Panic s)
116 = showString ("panic! (the 'impossible' happened)\n"
117 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
119 ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n")
121 myMkTyConApp :: TyCon -> [TypeRep] -> TypeRep
122 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
123 myMkTyConApp = mkAppTy
125 myMkTyConApp = mkTyConApp
128 ghcExceptionTc :: TyCon
129 ghcExceptionTc = mkTyCon "GhcException"
130 {-# NOINLINE ghcExceptionTc #-}
131 instance Typeable GhcException where
132 typeOf _ = myMkTyConApp ghcExceptionTc []
138 panic, pgmError :: String -> a
139 panic x = Exception.throwDyn (Panic x)
140 pgmError x = Exception.throwDyn (ProgramError x)
142 -- #-versions because panic can't return an unboxed int, and that's
143 -- what TAG_ is with GHC at the moment. Ugh. (Simon)
144 -- No, man -- Too Beautiful! (Will)
146 panicFastInt :: String -> FastInt
147 panicFastInt s = case (panic s) of () -> _ILIT(0)
149 assertPanic :: String -> Int -> a
150 assertPanic file line =
151 Exception.throw (Exception.AssertionFailed
152 ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
156 -- | tryMost is like try, but passes through Interrupted and Panic
157 -- exceptions. Used when we want soft failures when reading interface
158 -- files, for example.
160 tryMost :: IO a -> IO (Either Exception.Exception a)
161 tryMost action = do r <- try action; filter r
163 filter (Left e@(Exception.DynException d))
164 | Just ghc_ex <- fromDynamic d
166 Interrupted -> Exception.throw e
167 Panic _ -> Exception.throw e
168 _other -> return (Left e)
172 -- | tryUser is like try, but catches only UserErrors.
173 -- These are the ones that are thrown by the TcRn monad
174 -- to signal an error in the program being compiled
175 tryUser :: IO a -> IO (Either Exception.Exception a)
176 tryUser action = tryJust tc_errors action
178 tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
179 tc_errors _other = Nothing
182 Standard signal handlers for catching ^C, which just throw an
183 exception in the target thread. The current target thread is
184 the thread at the head of the list in the MVar passed to
185 installSignalHandlers.
188 installSignalHandlers :: IO ()
189 installSignalHandlers = do
191 interrupt_exn = Exception.DynException (toDyn Interrupted)
194 withMVar interruptTargetThread $ \targets ->
197 (thread:_) -> throwTo thread interrupt_exn
199 #if !defined(mingw32_HOST_OS)
200 installHandler sigQUIT (Catch interrupt) Nothing
201 installHandler sigINT (Catch interrupt) Nothing
203 #elif __GLASGOW_HASKELL__ >= 603
204 -- GHC 6.3+ has support for console events on Windows
205 -- NOTE: running GHCi under a bash shell for some reason requires
206 -- you to press Ctrl-Break rather than Ctrl-C to provoke
207 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
208 -- why --SDM 17/12/2004
209 let sig_handler ControlC = interrupt
210 sig_handler Break = interrupt
211 sig_handler _ = return ()
213 installHandler (Catch sig_handler)
219 {-# NOINLINE interruptTargetThread #-}
220 interruptTargetThread :: MVar [ThreadId]
221 interruptTargetThread = unsafePerformIO (newMVar [])