Commit 81466110 authored by Ian Lynagh's avatar Ian Lynagh

Follow changes in the base library

TopHandler now uses the new extensible exceptions module, so we
need to interact with it using the new types.
parent e61fe59d
...@@ -28,13 +28,11 @@ import StaticFlags ...@@ -28,13 +28,11 @@ import StaticFlags
import Data.Maybe import Data.Maybe
import Numeric import Numeric
import Exception
import Data.Array import Data.Array
import Data.Char import Data.Char
import Data.Int ( Int64 ) import Data.Int ( Int64 )
import Data.IORef import Data.IORef
import Data.List import Data.List
import Data.Typeable
import System.CPUTime import System.CPUTime
import System.Directory import System.Directory
import System.Environment import System.Environment
...@@ -140,9 +138,9 @@ instance Monad GHCi where ...@@ -140,9 +138,9 @@ instance Monad GHCi where
instance Functor GHCi where instance Functor GHCi where
fmap f m = m >>= return . f fmap f m = m >>= return . f
ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
ghciHandleDyn h (GHCi m) = GHCi $ \s -> ghciHandleGhcException h (GHCi m) = GHCi $ \s ->
Exception.catchDyn (m s) (\e -> unGHCi (h e) s) handleGhcException (\e -> unGHCi (h e) s) (m s)
getGHCiState :: GHCi GHCiState getGHCiState :: GHCi GHCiState
getGHCiState = GHCi $ \r -> readIORef r getGHCiState = GHCi $ \r -> readIORef r
......
...@@ -468,7 +468,7 @@ runGHCi paths maybe_exprs = do ...@@ -468,7 +468,7 @@ runGHCi paths maybe_exprs = do
interactiveLoop :: Bool -> Bool -> GHCi () interactiveLoop :: Bool -> Bool -> GHCi ()
interactiveLoop is_tty show_prompt = interactiveLoop is_tty show_prompt =
-- Ignore ^C exceptions caught here -- Ignore ^C exceptions caught here
ghciHandleDyn (\e -> case e of ghciHandleGhcException (\e -> case e of
Interrupted -> do Interrupted -> do
#if defined(mingw32_HOST_OS) #if defined(mingw32_HOST_OS)
io (putStrLn "") io (putStrLn "")
...@@ -504,7 +504,7 @@ checkPerms _ = ...@@ -504,7 +504,7 @@ checkPerms _ =
return True return True
#else #else
checkPerms name = checkPerms name =
Util.handle (\_ -> return False) $ do handleIO (\_ -> return False) $ do
st <- getFileStatus name st <- getFileStatus name
me <- getRealUserID me <- getRealUserID
if fileOwner st /= me then do if fileOwner st /= me then do
...@@ -650,7 +650,7 @@ queryQueue = do ...@@ -650,7 +650,7 @@ queryQueue = do
runCommands :: GHCi (Maybe String) -> GHCi () runCommands :: GHCi (Maybe String) -> GHCi ()
runCommands = runCommands' handler runCommands = runCommands' handler
runCommands' :: (Exception -> GHCi Bool) -- Exception handler runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
-> GHCi (Maybe String) -> GHCi () -> GHCi (Maybe String) -> GHCi ()
runCommands' eh getCmd = do runCommands' eh getCmd = do
mb_cmd <- noSpace queryQueue mb_cmd <- noSpace queryQueue
...@@ -1822,14 +1822,15 @@ completeHomeModuleOrFile=completeNone ...@@ -1822,14 +1822,15 @@ completeHomeModuleOrFile=completeNone
-- raising another exception. We therefore don't put the recursive -- raising another exception. We therefore don't put the recursive
-- handler arond the flushing operation, so if stderr is closed -- handler arond the flushing operation, so if stderr is closed
-- GHCi will just die gracefully rather than going into an infinite loop. -- GHCi will just die gracefully rather than going into an infinite loop.
handler :: Exception -> GHCi Bool handler :: SomeException -> GHCi Bool
handler exception = do handler exception = do
flushInterpBuffers flushInterpBuffers
io installSignalHandlers io installSignalHandlers
ghciHandle handler (showException exception >> return False) ghciHandle handler (showException exception >> return False)
showException :: Exception -> GHCi () showException :: SomeException -> GHCi ()
#if __GLASGOW_HASKELL__ < 609
showException (DynException dyn) = showException (DynException dyn) =
case fromDynamic dyn of case fromDynamic dyn of
Nothing -> io (putStrLn ("*** Exception: (unknown)")) Nothing -> io (putStrLn ("*** Exception: (unknown)"))
...@@ -1840,6 +1841,17 @@ showException (DynException dyn) = ...@@ -1840,6 +1841,17 @@ showException (DynException dyn) =
showException other_exception showException other_exception
= io (putStrLn ("*** Exception: " ++ show other_exception)) = io (putStrLn ("*** Exception: " ++ show other_exception))
#else
showException (SomeException e) =
io $ case cast e of
Just Interrupted -> putStrLn "Interrupted."
-- omit the location for CmdLineError:
Just (CmdLineError s) -> putStrLn s
-- ditto:
Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
Just other_ghc_ex -> print other_ghc_ex
Nothing -> putStrLn ("*** Exception: " ++ show e)
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- recursive exception handlers -- recursive exception handlers
...@@ -1848,7 +1860,7 @@ showException other_exception ...@@ -1848,7 +1860,7 @@ showException other_exception
-- in an exception loop (eg. let a = error a in a) the ^C exception -- in an exception loop (eg. let a = error a in a) the ^C exception
-- may never be delivered. Thanks to Marcin for pointing out the bug. -- may never be delivered. Thanks to Marcin for pointing out the bug.
ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
ghciHandle h (GHCi m) = GHCi $ \s -> ghciHandle h (GHCi m) = GHCi $ \s ->
Exception.catch (m s) Exception.catch (m s)
(\e -> unGHCi (ghciUnblock (h e)) s) (\e -> unGHCi (ghciUnblock (h e)) s)
...@@ -1856,7 +1868,7 @@ ghciHandle h (GHCi m) = GHCi $ \s -> ...@@ -1856,7 +1868,7 @@ ghciHandle h (GHCi m) = GHCi $ \s ->
ghciUnblock :: GHCi a -> GHCi a ghciUnblock :: GHCi a -> GHCi a
ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
ghciTry :: GHCi a -> GHCi (Either Exception a) ghciTry :: GHCi a -> GHCi (Either SomeException a)
ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s) ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s)
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
...@@ -2174,7 +2186,7 @@ findBreakByCoord mb_file (line, col) arr ...@@ -2174,7 +2186,7 @@ findBreakByCoord mb_file (line, col) arr
do_bold :: Bool do_bold :: Bool
do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
where mTerm = System.Environment.getEnv "TERM" where mTerm = System.Environment.getEnv "TERM"
`Exception.catch` \_ -> return "TERM not set" `catchIO` \_ -> return "TERM not set"
start_bold :: String start_bold :: String
start_bold = "\ESC[1m" start_bold = "\ESC[1m"
......
...@@ -1131,7 +1131,7 @@ mkSOName root ...@@ -1131,7 +1131,7 @@ mkSOName root
-- name. They are searched for in different paths than normal libraries. -- name. They are searched for in different paths than normal libraries.
loadFramework :: [FilePath] -> FilePath -> IO (Maybe String) loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
loadFramework extraPaths rootname loadFramework extraPaths rootname
= do { either_dir <- Exception.try getHomeDirectory = do { either_dir <- tryIO getHomeDirectory
; let homeFrameworkPath = case either_dir of ; let homeFrameworkPath = case either_dir of
Left _ -> [] Left _ -> []
Right dir -> [dir ++ "/Library/Frameworks"] Right dir -> [dir ++ "/Library/Frameworks"]
......
...@@ -31,6 +31,7 @@ import SrcLoc ...@@ -31,6 +31,7 @@ import SrcLoc
import Data.List import Data.List
import FastString import FastString
import Exception
import ErrUtils ( debugTraceMsg, putMsg ) import ErrUtils ( debugTraceMsg, putMsg )
import System.Exit ( ExitCode(..), exitWith ) import System.Exit ( ExitCode(..), exitWith )
...@@ -126,9 +127,9 @@ beginMkDependHS dflags = do ...@@ -126,9 +127,9 @@ beginMkDependHS dflags = do
then return () then return ()
else chuck else chuck
catchJust ioErrors slurp catchIO slurp
(\e -> if isEOFError e then return () else ioError e) (\e -> if isEOFError e then return () else ioError e)
catchJust ioErrors chuck catchIO chuck
(\e -> if isEOFError e then return () else ioError e) (\e -> if isEOFError e then return () else ioError e)
return (Just makefile_hdl) return (Just makefile_hdl)
...@@ -295,7 +296,7 @@ endMkDependHS dflags ...@@ -295,7 +296,7 @@ endMkDependHS dflags
hPutStrLn tmp_hdl l hPutStrLn tmp_hdl l
slurp slurp
catchJust ioErrors slurp catchIO slurp
(\e -> if isEOFError e then return () else ioError e) (\e -> if isEOFError e then return () else ioError e)
hClose hdl hClose hdl
......
...@@ -1120,7 +1120,7 @@ runPhase_MoveBinary dflags input_fn dep_packages ...@@ -1120,7 +1120,7 @@ runPhase_MoveBinary dflags input_fn dep_packages
pvm_executable_base = "=" ++ input_fn pvm_executable_base = "=" ++ input_fn
pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
-- nuke old binary; maybe use configur'ed names for cp and rm? -- nuke old binary; maybe use configur'ed names for cp and rm?
Panic.try (removeFile pvm_executable) tryIO (removeFile pvm_executable)
-- move the newly created binary into PVM land -- move the newly created binary into PVM land
copy dflags "copying PVM executable" input_fn pvm_executable copy dflags "copying PVM executable" input_fn pvm_executable
-- generate a wrapper script for running a parallel prg under PVM -- generate a wrapper script for running a parallel prg under PVM
......
...@@ -8,7 +8,7 @@ module ErrUtils ( ...@@ -8,7 +8,7 @@ module ErrUtils (
Message, mkLocMessage, printError, Message, mkLocMessage, printError,
Severity(..), Severity(..),
ErrMsg, WarnMsg, ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages, Messages, errorsFound, emptyMessages,
mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
...@@ -44,6 +44,7 @@ import System.Exit ( ExitCode(..), exitWith ) ...@@ -44,6 +44,7 @@ import System.Exit ( ExitCode(..), exitWith )
import Data.Dynamic import Data.Dynamic
import Data.List import Data.List
import System.IO import System.IO
import Exception
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location. -- Basic error messages: just render a message with a source location.
...@@ -81,6 +82,27 @@ data ErrMsg = ErrMsg { ...@@ -81,6 +82,27 @@ data ErrMsg = ErrMsg {
-- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic
-- whether to qualify an External Name) at the error occurrence -- whether to qualify an External Name) at the error occurrence
#if __GLASGOW_HASKELL__ >= 609
instance Exception ErrMsg
#endif
instance Show ErrMsg where
show em = showSDoc (errMsgShortDoc em)
throwErrMsg :: ErrMsg -> a
#if __GLASGOW_HASKELL__ < 609
throwErrMsg = throwDyn
#else
throwErrMsg = throw
#endif
handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
#if __GLASGOW_HASKELL__ < 609
handleErrMsg = flip catchDyn
#else
handleErrMsg = handle
#endif
-- So we can throw these things as exceptions -- So we can throw these things as exceptions
errMsgTc :: TyCon errMsgTc :: TyCon
errMsgTc = mkTyCon "ErrMsg" errMsgTc = mkTyCon "ErrMsg"
......
...@@ -274,11 +274,14 @@ import qualified Data.List as List ...@@ -274,11 +274,14 @@ import qualified Data.List as List
import Control.Monad import Control.Monad
import System.Exit ( exitWith, ExitCode(..) ) import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime, getClockTime ) import System.Time ( ClockTime, getClockTime )
import Exception hiding (handle) import Exception
import Data.IORef import Data.IORef
import System.FilePath import System.FilePath
import System.IO import System.IO
import System.IO.Error ( try, isDoesNotExistError ) import System.IO.Error ( try, isDoesNotExistError )
#if __GLASGOW_HASKELL__ >= 609
import Data.Typeable (cast)
#endif
import Prelude hiding (init) import Prelude hiding (init)
...@@ -290,33 +293,55 @@ import Prelude hiding (init) ...@@ -290,33 +293,55 @@ import Prelude hiding (init)
-- the top level of your program. The default handlers output the error -- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly. -- message(s) to stderr and exit cleanly.
defaultErrorHandler :: DynFlags -> IO a -> IO a defaultErrorHandler :: DynFlags -> IO a -> IO a
defaultErrorHandler dflags inner = defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug. -- top-level exception handler: any unrecognised exception is a compiler bug.
#if __GLASGOW_HASKELL__ < 609
handle (\exception -> do handle (\exception -> do
hFlush stdout hFlush stdout
case exception of case exception of
-- an IO exception probably isn't our fault, so don't panic -- an IO exception probably isn't our fault, so don't panic
IOException _ -> IOException _ ->
fatalErrorMsg dflags (text (show exception)) fatalErrorMsg dflags (text (show exception))
AsyncException StackOverflow -> AsyncException StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it") fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
_other -> ExitException _ -> throw exception
fatalErrorMsg dflags (text (show (Panic (show exception)))) _ ->
exitWith (ExitFailure 1) fatalErrorMsg dflags (text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
#else
handle (\(SomeException exception) -> do
hFlush stdout
case cast exception of
-- an IO exception probably isn't our fault, so don't panic
Just (ioe :: IOException) ->
fatalErrorMsg dflags (text (show ioe))
_ -> case cast exception of
Just StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
_ -> case cast exception of
Just (ex :: ExitCode) -> throw ex
_ ->
fatalErrorMsg dflags
(text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $ ) $
#endif
-- program errors: messages with locations attached. Sometimes it is -- program errors: messages with locations attached. Sometimes it is
-- convenient to just throw these as exceptions. -- convenient to just throw these as exceptions.
handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) handleErrMsg
exitWith (ExitFailure 1)) $ (\em -> do printBagOfErrors dflags (unitBag em)
exitWith (ExitFailure 1)) $
-- error messages propagated as exceptions -- error messages propagated as exceptions
handleDyn (\dyn -> do handleGhcException
(\ge -> do
hFlush stdout hFlush stdout
case dyn of case ge of
PhaseFailed _ code -> exitWith code PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1) Interrupted -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException))) _ -> do fatalErrorMsg dflags (text (show ge))
exitWith (ExitFailure 1) exitWith (ExitFailure 1)
) $ ) $
inner inner
...@@ -328,13 +353,13 @@ defaultErrorHandler dflags inner = ...@@ -328,13 +353,13 @@ defaultErrorHandler dflags inner =
defaultCleanupHandler :: DynFlags -> IO a -> IO a defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner = defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves -- make sure we clean up after ourselves
later (do cleanTempFiles dflags inner `onException`
(do cleanTempFiles dflags
cleanTempDirs dflags cleanTempDirs dflags
) )
-- exceptions will be blocked while we clean the temporary files, -- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further -- so there shouldn't be any difficulty if we receive further
-- signals. -- signals.
inner
-- | Starts a new session. A session consists of a set of loaded -- | Starts a new session. A session consists of a set of loaded
...@@ -465,7 +490,8 @@ guessTarget file Nothing ...@@ -465,7 +490,8 @@ guessTarget file Nothing
if exists if exists
then return (Target (TargetFile lhs_file Nothing) Nothing) then return (Target (TargetFile lhs_file Nothing) Nothing)
else do else do
throwDyn (ProgramError (showSDoc $ throwGhcException
(ProgramError (showSDoc $
text "target" <+> quotes (text file) <+> text "target" <+> quotes (text file) <+>
text "is not a module name or a source file")) text "is not a module name or a source file"))
where where
...@@ -1661,7 +1687,8 @@ downsweep :: HscEnv ...@@ -1661,7 +1687,8 @@ downsweep :: HscEnv
-- in which case there can be repeats -- in which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots downsweep hsc_env old_summaries excl_mods allow_dup_roots
= -- catch error messages and return them = -- catch error messages and return them
handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do handleErrMsg
(\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
rootSummaries <- mapM getRootSummary roots rootSummaries <- mapM getRootSummary roots
let root_map = mkRootMap rootSummaries let root_map = mkRootMap rootSummaries
checkDuplicates root_map checkDuplicates root_map
...@@ -1678,7 +1705,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots ...@@ -1678,7 +1705,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
= do exists <- doesFileExist file = do exists <- doesFileExist file
if exists if exists
then summariseFile hsc_env old_summaries file mb_phase maybe_buf then summariseFile hsc_env old_summaries file mb_phase maybe_buf
else throwDyn $ mkPlainErrMsg noSrcSpan $ else throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "can't find file:" <+> text file text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) maybe_buf) getRootSummary (Target (TargetModule modl) maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map False = do maybe_summary <- summariseModule hsc_env old_summary_map False
...@@ -1928,7 +1955,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc ...@@ -1928,7 +1955,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
(srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $ when (mod_name /= wanted_mod) $
throwDyn $ mkPlainErrMsg mod_loc $ throwErrMsg $ mkPlainErrMsg mod_loc $
text "File name does not match module name:" text "File name does not match module name:"
$$ text "Saw:" <+> quotes (ppr mod_name) $$ text "Saw:" <+> quotes (ppr mod_name)
$$ text "Expected:" <+> quotes (ppr wanted_mod) $$ text "Expected:" <+> quotes (ppr wanted_mod)
...@@ -1995,21 +2022,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) ...@@ -1995,21 +2022,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
-- ToDo: we don't have a proper line number for this error -- ToDo: we don't have a proper line number for this error
noModError dflags loc wanted_mod err noModError dflags loc wanted_mod err
= throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
noHsFileErr :: SrcSpan -> String -> a noHsFileErr :: SrcSpan -> String -> a
noHsFileErr loc path noHsFileErr loc path
= throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
packageModErr :: ModuleName -> a packageModErr :: ModuleName -> a
packageModErr mod packageModErr mod
= throwDyn $ mkPlainErrMsg noSrcSpan $ = throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module" text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr :: [ModSummary] -> IO () multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr" multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_) multiRootsErr summs@(summ1:_)
= throwDyn $ mkPlainErrMsg noSrcSpan $ = throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+> text "is defined in multiple files:" <+>
sep (map text files) sep (map text files)
......
...@@ -70,7 +70,7 @@ getImports dflags buf filename source_filename = do ...@@ -70,7 +70,7 @@ getImports dflags buf filename source_filename = do
return (source_imps, ordinary_imps, mod) return (source_imps, ordinary_imps, mod)
parseError :: SrcSpan -> Message -> a parseError :: SrcSpan -> Message -> a
parseError span err = throwDyn $ mkPlainErrMsg span err parseError span err = throwErrMsg $ mkPlainErrMsg span err
isSourceIdecl :: ImportDecl name -> Bool isSourceIdecl :: ImportDecl name -> Bool
isSourceIdecl (ImportDecl _ s _ _ _) = s isSourceIdecl (ImportDecl _ s _ _ _) = s
......
...@@ -90,13 +90,13 @@ import Foreign.StablePtr ...@@ -90,13 +90,13 @@ import Foreign.StablePtr
data RunResult data RunResult
= RunOk [Name] -- ^ names bound by this evaluation = RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation | RunFailed -- ^ statement failed compilation
| RunException Exception -- ^ statement raised an exception | RunException SomeException -- ^ statement raised an exception
| RunBreak ThreadId [Name] (Maybe BreakInfo) | RunBreak ThreadId [Name] (Maybe BreakInfo)
data Status data Status
= Break Bool HValue BreakInfo ThreadId = Break Bool HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint (Bool <=> was an exception) -- ^ the computation hit a breakpoint (Bool <=> was an exception)
| Complete (Either Exception [HValue]) | Complete (Either SomeException [HValue])
-- ^ the computation completed with either an exception or a value -- ^ the computation completed with either an exception or a value
data Resume data Resume
...@@ -338,6 +338,7 @@ sandboxIO dflags statusMVar thing = ...@@ -338,6 +338,7 @@ sandboxIO dflags statusMVar thing =
-- not "Interrupted", we unset the exception flag before throwing. -- not "Interrupted", we unset the exception flag before throwing.
-- --
rethrow :: DynFlags -> IO a -> IO a rethrow :: DynFlags -> IO a -> IO a
#if __GLASGOW_HASKELL__ < 609
rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
case e of case e of
-- If -fbreak-on-error, we break unconditionally, -- If -fbreak-on-error, we break unconditionally,
...@@ -355,7 +356,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn ...@@ -355,7 +356,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
_ -> poke exceptionFlag 0 _ -> poke exceptionFlag 0
Exception.throwIO e Exception.throwIO e
#else
rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
-- If -fbreak-on-error, we break unconditionally,
-- but with care of not breaking twice
if dopt Opt_BreakOnError dflags &&
not (dopt Opt_BreakOnException dflags)
then poke exceptionFlag 1
else case cast e of
-- If it is an "Interrupted" exception, we allow
-- a possible break by way of -fbreak-on-exception
Just Interrupted -> return ()
-- In any other case, we don't want to break
_ -> poke exceptionFlag 0
Exception.throwIO se
#endif
withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do withInterruptsSentTo thread get_result = do
......
...@@ -55,6 +55,7 @@ import Distribution.Text ...@@ -55,6 +55,7 @@ import Distribution.Text
import Distribution.Version