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 #include "HsVersions.h"
30 #ifndef mingw32_HOST_OS
31 import System.Posix.Signals
32 #endif /* mingw32_HOST_OS */
34 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 603
35 import GHC.ConsoleHandler
38 import Control.Exception
39 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
41 import qualified Control.Exception as Exception
42 import Debug.Trace ( trace )
43 import System.IO.Unsafe ( unsafePerformIO )
44 import System.IO.Error ( isUserError )
46 import System.Environment
49 GHC's own exception type.
52 ghcError :: GhcException -> a
53 ghcError e = Exception.throwDyn e
55 -- error messages all take the form
57 -- <location>: <error>
59 -- If the location is on the command line, or in GHC itself, then
60 -- <location>="ghc". All of the error types below correspond to
61 -- a <location> of "ghc", except for ProgramError (where the string is
62 -- assumed to contain a location already, so we don't print one).
65 = PhaseFailed String -- name of phase
66 ExitCode -- an external phase (eg. cpp) failed
67 | Interrupted -- someone pressed ^C
68 | UsageError String -- prints the short usage msg after the error
69 | CmdLineError String -- cmdline prob, but doesn't print usage
70 | Panic String -- the `impossible' happened
71 | InstallationError String -- an installation problem
72 | ProgramError String -- error in the user's code, probably
76 progName = unsafePerformIO (getProgName)
77 {-# NOINLINE progName #-}
80 short_usage = "Usage: For basic information, try the `--help' option."
82 showException :: Exception.Exception -> String
83 -- Show expected dynamic exceptions specially
84 showException (Exception.DynException d) | Just e <- fromDynamic d
85 = show (e::GhcException)
86 showException other_exn = show other_exn
88 instance Show GhcException where
89 showsPrec _ e@(ProgramError _) = showGhcException e
90 showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
91 showsPrec _ e = showString progName . showString ": " . showGhcException e
93 showGhcException :: GhcException -> String -> String
94 showGhcException (UsageError str)
95 = showString str . showChar '\n' . showString short_usage
96 showGhcException (PhaseFailed phase code)
97 = showString "phase `" . showString phase .
98 showString "' failed (exitcode = " . shows int_code .
103 ExitSuccess -> (0::Int)
105 showGhcException (CmdLineError str)
107 showGhcException (ProgramError str)
109 showGhcException (InstallationError str)
111 showGhcException (Interrupted)
112 = showString "interrupted"
113 showGhcException (Panic s)
114 = showString ("panic! (the 'impossible' happened)\n"
115 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
117 ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n")
119 myMkTyConApp :: TyCon -> [TypeRep] -> TypeRep
120 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
121 myMkTyConApp = mkAppTy
123 myMkTyConApp = mkTyConApp
126 ghcExceptionTc :: TyCon
127 ghcExceptionTc = mkTyCon "GhcException"
128 {-# NOINLINE ghcExceptionTc #-}
129 instance Typeable GhcException where
130 typeOf _ = myMkTyConApp ghcExceptionTc []
136 panic, pgmError :: String -> a
137 panic x = Exception.throwDyn (Panic x)
138 pgmError x = Exception.throwDyn (ProgramError x)
140 -- #-versions because panic can't return an unboxed int, and that's
141 -- what TAG_ is with GHC at the moment. Ugh. (Simon)
142 -- No, man -- Too Beautiful! (Will)
144 panicFastInt :: String -> FastInt
145 panicFastInt s = case (panic s) of () -> _ILIT(0)
147 assertPanic :: String -> Int -> a
148 assertPanic file line =
149 Exception.throw (Exception.AssertionFailed
150 ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
154 -- | tryMost is like try, but passes through Interrupted and Panic
155 -- exceptions. Used when we want soft failures when reading interface
156 -- files, for example.
158 tryMost :: IO a -> IO (Either Exception.Exception a)
159 tryMost action = do r <- try action; filter r
161 filter (Left e@(Exception.DynException d))
162 | Just ghc_ex <- fromDynamic d
164 Interrupted -> Exception.throw e
165 Panic _ -> Exception.throw e
166 _other -> return (Left e)
170 -- | tryUser is like try, but catches only UserErrors.
171 -- These are the ones that are thrown by the TcRn monad
172 -- to signal an error in the program being compiled
173 tryUser :: IO a -> IO (Either Exception.Exception a)
174 tryUser action = tryJust tc_errors action
176 tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
177 tc_errors _other = Nothing
180 Standard signal handlers for catching ^C, which just throw an
181 exception in the target thread. The current target thread is
182 the thread at the head of the list in the MVar passed to
183 installSignalHandlers.
186 installSignalHandlers :: IO ()
187 installSignalHandlers = do
189 interrupt_exn = Exception.DynException (toDyn Interrupted)
192 withMVar interruptTargetThread $ \targets ->
195 (thread:_) -> throwTo thread interrupt_exn
197 #if !defined(mingw32_HOST_OS)
198 installHandler sigQUIT (Catch interrupt) Nothing
199 installHandler sigINT (Catch interrupt) Nothing
201 #elif __GLASGOW_HASKELL__ >= 603
202 -- GHC 6.3+ has support for console events on Windows
203 -- NOTE: running GHCi under a bash shell for some reason requires
204 -- you to press Ctrl-Break rather than Ctrl-C to provoke
205 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
206 -- why --SDM 17/12/2004
207 let sig_handler ControlC = interrupt
208 sig_handler Break = interrupt
209 sig_handler _ = return ()
211 installHandler (Catch sig_handler)
217 {-# NOINLINE interruptTargetThread #-}
218 interruptTargetThread :: MVar [ThreadId]
219 interruptTargetThread = unsafePerformIO (newMVar [])