[commit: ghc] master: Change a few throwGhcException uses to throwGhcExceptionIO (0a1b7cb)
Ian Lynagh
igloo at earth.li
Thu Jan 31 01:29:44 CET 2013
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/0a1b7cb85fac3988ae625ba8bb491de81c39bfdc
>---------------------------------------------------------------
commit 0a1b7cb85fac3988ae625ba8bb491de81c39bfdc
Author: Ian Lynagh <ian at well-typed.com>
Date: Wed Jan 30 14:06:53 2013 +0000
Change a few throwGhcException uses to throwGhcExceptionIO
>---------------------------------------------------------------
compiler/iface/BinIface.hs | 2 +-
compiler/iface/LoadIface.lhs | 2 +-
compiler/iface/MkIface.lhs | 2 +-
compiler/main/DriverMkDepend.hs | 6 +++---
compiler/main/GhcMake.hs | 2 +-
compiler/main/SysTools.lhs | 8 ++++----
compiler/simplCore/SimplCore.lhs | 6 ++++--
7 files changed, 15 insertions(+), 13 deletions(-)
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 7f9b24e..5a751f7 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -96,7 +96,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
errorOnMismatch what wanted got =
-- This will be caught by readIface which will emit an error
-- msg containing the iface module name.
- when (wanted /= got) $ throwGhcException $ ProgramError
+ when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
(what ++ " (wanted " ++ show wanted
++ ", got " ++ show got ++ ")")
bh <- Binary.readBinMem hi_path
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 783a0e9..93e8e96 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -172,7 +172,7 @@ loadInterfaceWithException doc mod_name where_from
= do { mb_iface <- loadInterface doc mod_name where_from
; dflags <- getDynFlags
; case mb_iface of
- Failed err -> throwGhcException (ProgramError (showSDoc dflags err))
+ Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
Succeeded iface -> return iface }
------------------
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index b7ebe91..c0ae73a 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -829,7 +829,7 @@ oldMD5 dflags bh = do
let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
r <- system cmd
case r of
- ExitFailure _ -> throwGhcException (PhaseFailed cmd r)
+ ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
ExitSuccess -> do
hash_str <- readFile tmp2
return $! readHexFingerprint hash_str
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 5a2b727..cda0b47 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -64,8 +64,8 @@ doMkDependHS srcs = do
}
_ <- GHC.setSessionDynFlags dflags
- when (null (depSuffixes dflags)) $
- throwGhcException (ProgramError "You must specify at least one -dep-suffix")
+ when (null (depSuffixes dflags)) $ liftIO $
+ throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
files <- liftIO $ beginMkDependHS dflags
@@ -193,7 +193,7 @@ processDeps :: DynFlags
processDeps dflags _ _ _ _ (CyclicSCC nodes)
= -- There shouldn't be any cycles; report them
- throwGhcException (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
+ throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
= do { let extra_suffixes = depSuffixes dflags
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 80227cd..81f338e 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1425,7 +1425,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
| otherwise = False
when needs_preprocessing $
- throwGhcException (ProgramError "buffer needs preprocesing; interactive check disabled")
+ throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
return (dflags', src_fn, buf)
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 28ff499..e648481 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -353,7 +353,7 @@ findTopDir Nothing
maybe_exec_dir <- getBaseDir
case maybe_exec_dir of
-- "Just" on Windows, "Nothing" on unix
- Nothing -> throwGhcException (InstallationError "missing -B<dir> option")
+ Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
Just dir -> return dir
\end{code}
@@ -837,14 +837,14 @@ handleProc pgm phase_name proc = do
-- the case of a missing program there will otherwise be no output
-- at all.
| n == 127 -> does_not_exist
- | otherwise -> throwGhcException (PhaseFailed phase_name rc)
+ | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
where
handler err =
if IO.isDoesNotExistError err
then does_not_exist
else IO.ioError err
- does_not_exist = throwGhcException (InstallationError ("could not execute: " ++ pgm))
+ does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
builderMainLoop :: DynFlags -> (String -> String) -> FilePath
@@ -976,7 +976,7 @@ traceCmd dflags phase_name cmd_line action
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
- ; throwGhcException (PhaseFailed phase_name (ExitFailure 1)) }
+ ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
%************************************************************************
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 8270260..51761db 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -334,7 +334,8 @@ loadPlugin hsc_env mod_name
dflags = hsc_dflags hsc_env
; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name
; case mb_name of {
- Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep
+ Nothing ->
+ throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The module"), ppr mod_name
, ptext (sLit "did not export the plugin name")
, ppr plugin_rdr_name ]) ;
@@ -343,7 +344,8 @@ loadPlugin hsc_env mod_name
do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
; case mb_plugin of
- Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep
+ Nothing ->
+ throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The value"), ppr name
, ptext (sLit "did not have the type")
, ppr pluginTyConName, ptext (sLit "as required")])
More information about the ghc-commits
mailing list