summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghci/ByteCodeGen.lhs2
-rw-r--r--compiler/ghci/ByteCodeLink.lhs2
-rw-r--r--compiler/ghci/LibFFI.hsc2
-rw-r--r--compiler/ghci/Linker.lhs26
-rw-r--r--compiler/iface/BinIface.hs2
-rw-r--r--compiler/iface/LoadIface.lhs2
-rw-r--r--compiler/iface/MkIface.lhs2
-rw-r--r--compiler/main/DriverMkDepend.hs4
-rw-r--r--compiler/main/DriverPipeline.hs6
-rw-r--r--compiler/main/DynFlags.hs8
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/main/GhcMake.hs4
-rw-r--r--compiler/main/InteractiveEval.hs10
-rw-r--r--compiler/main/Packages.lhs12
-rw-r--r--compiler/main/StaticFlagParser.hs6
-rw-r--r--compiler/main/StaticFlags.hs2
-rw-r--r--compiler/main/SysTools.lhs8
-rw-r--r--compiler/utils/Panic.lhs6
-rw-r--r--ghc/GhciTags.hs8
-rw-r--r--ghc/InteractiveUI.hs48
-rw-r--r--ghc/Main.hs18
21 files changed, 88 insertions, 92 deletions
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index bd636c9b77..2b332a4581 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -1465,7 +1465,7 @@ bcIdUnaryType x = case repType (idType x) of
-- See bug #1257
unboxedTupleException :: a
unboxedTupleException
- = ghcError
+ = throwGhcException
(ProgramError
("Error: bytecode compiler can't handle unboxed tuples.\n"++
" Possibly due to foreign import/export decls in source.\n"++
diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
index 8938bfe4f1..6fcb7f4f66 100644
--- a/compiler/ghci/ByteCodeLink.lhs
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -240,7 +240,7 @@ lookupIE dflags ie con_nm
linkFail :: String -> String -> IO a
linkFail who what
- = ghcError (ProgramError $
+ = throwGhcException (ProgramError $
unlines [ "",who
, "During interactive linking, GHCi couldn't find the following symbol:"
, ' ' : ' ' : what
diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc
index 128197109b..d46d1b94cd 100644
--- a/compiler/ghci/LibFFI.hsc
+++ b/compiler/ghci/LibFFI.hsc
@@ -52,7 +52,7 @@ prepForeignCall dflags cconv arg_types result_type
let res_ty = primRepToFFIType dflags result_type
r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
if (r /= fFI_OK)
- then ghcError (InstallationError
+ then throwGhcException (InstallationError
(printf "prepForeignCallFailed: %d" (show r)))
else return cif
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 3ba9c3c36a..7d36337fc1 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -172,7 +172,7 @@ getHValue hsc_env name = do
pls <- modifyPLS $ \pls -> do
if (isExternalName name) then do
(pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
- if (failed ok) then ghcError (ProgramError "")
+ if (failed ok) then throwGhcException (ProgramError "")
else return (pls', pls')
else
return (pls, pls)
@@ -321,7 +321,7 @@ reallyInitDynLinker dflags =
; ok <- resolveObjs
; if succeeded ok then maybePutStrLn dflags "done"
- else ghcError (ProgramError "linking extra libraries/objects failed")
+ else throwGhcException (ProgramError "linking extra libraries/objects failed")
; return pls
}}
@@ -403,7 +403,7 @@ preloadLib dflags lib_paths framework_paths lib_spec
preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
preloadFailed sys_errmsg paths spec
= do maybePutStr dflags "failed.\n"
- ghcError $
+ throwGhcException $
CmdLineError (
"user specified .o/.so/.DLL could not be loaded ("
++ sys_errmsg ++ ")\nWhilst trying to load: "
@@ -455,7 +455,7 @@ linkExpr hsc_env span root_ul_bco
-- Link the packages and modules required
; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
; if failed ok then
- ghcError (ProgramError "")
+ throwGhcException (ProgramError "")
else do {
-- Link the expression itself
@@ -480,7 +480,7 @@ linkExpr hsc_env span root_ul_bco
-- by default, so we can safely ignore them here.
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
-dieWith dflags span msg = ghcError (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
+dieWith dflags span msg = throwGhcException (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool
@@ -566,7 +566,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
mb_iface <- initIfaceCheck hsc_env $
loadInterface msg mod (ImportByUser False)
iface <- case mb_iface of
- Maybes.Failed err -> ghcError (ProgramError (showSDoc dflags err))
+ Maybes.Failed err -> throwGhcException (ProgramError (showSDoc dflags err))
Maybes.Succeeded iface -> return iface
when (mi_boot iface) $ link_boot_mod_error mod
@@ -594,7 +594,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
link_boot_mod_error mod =
- ghcError (ProgramError (showSDoc dflags (
+ throwGhcException (ProgramError (showSDoc dflags (
text "module" <+> ppr mod <+>
text "cannot be linked; it is only available as a boot module")))
@@ -677,7 +677,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
-- Link the packages and modules required
(pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
if failed ok
- then ghcError (ProgramError "")
+ then throwGhcException (ProgramError "")
else do
-- Link the expression itself
@@ -717,7 +717,7 @@ linkModule hsc_env mod = do
initDynLinker (hsc_dflags hsc_env)
modifyPLS_ $ \pls -> do
(pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
- if (failed ok) then ghcError (ProgramError "could not link module")
+ if (failed ok) then throwGhcException (ProgramError "could not link module")
else return pls'
\end{code}
@@ -1084,7 +1084,7 @@ linkPackages' dflags new_pks pls = do
; return (new_pkg : pkgs') }
| otherwise
- = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
+ = throwGhcException (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
linkPackage :: DynFlags -> PackageConfig -> IO ()
@@ -1140,7 +1140,7 @@ linkPackage dflags pkg
maybePutStr dflags "linking ... "
ok <- resolveObjs
if succeeded ok then maybePutStrLn dflags "done."
- else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
+ else throwGhcException (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
-- we have already searched the filesystem; the strings passed to load_dyn
-- can be passed directly to loadDLL. They are either fully-qualified
@@ -1151,7 +1151,7 @@ load_dyn :: FilePath -> IO ()
load_dyn dll = do r <- loadDLL dll
case r of
Nothing -> return ()
- Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
+ Just err -> throwGhcException (CmdLineError ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")" ))
loadFrameworks :: Platform -> InstalledPackageInfo_ ModuleName -> IO ()
@@ -1166,7 +1166,7 @@ loadFrameworks platform pkg
load fw = do r <- loadFramework fw_dirs fw
case r of
Nothing -> return ()
- Just err -> ghcError (CmdLineError ("can't load framework: "
+ Just err -> throwGhcException (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
-- Try to find an object file for a given library in the given paths.
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 616bc0acf4..5d667ced4f 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -98,7 +98,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) $ ghcError $ ProgramError
+ when (wanted /= got) $ throwGhcException $ 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 6dfac27d5d..85c8a7848d 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -166,7 +166,7 @@ loadInterfaceWithException doc mod_name where_from
= do { mb_iface <- loadInterface doc mod_name where_from
; dflags <- getDynFlags
; case mb_iface of
- Failed err -> ghcError (ProgramError (showSDoc dflags err))
+ Failed err -> throwGhcException (ProgramError (showSDoc dflags err))
Succeeded iface -> return iface }
------------------
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index b27c7c667a..40d1727243 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 _ -> ghcError (PhaseFailed cmd r)
+ ExitFailure _ -> throwGhcException (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 a2413d5151..5a2b727ea6 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -65,7 +65,7 @@ doMkDependHS srcs = do
_ <- GHC.setSessionDynFlags dflags
when (null (depSuffixes dflags)) $
- ghcError (ProgramError "You must specify at least one -dep-suffix")
+ throwGhcException (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
- ghcError (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
+ throwGhcException (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/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index da4f674514..d0e1ca88b5 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -430,7 +430,7 @@ compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile hsc_env stop_phase (src, mb_phase) = do
exists <- doesFileExist src
when (not exists) $
- ghcError (CmdLineError ("does not exist: " ++ src))
+ throwGhcException (CmdLineError ("does not exist: " ++ src))
let
dflags = hsc_dflags hsc_env
@@ -526,7 +526,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
-- before B in a normal compilation pipeline.
when (not (start_phase `happensBefore` stop_phase)) $
- ghcError (UsageError
+ throwGhcException (UsageError
("cannot compile this file to desired target: "
++ input_fn))
@@ -1813,7 +1813,7 @@ linkBinary dflags o_files dep_packages = do
-- parallel only: move binary to another dir -- HWL
success <- runPhase_MoveBinary dflags output_fn
if success then return ()
- else ghcError (InstallationError ("cannot move binary"))
+ else throwGhcException (InstallationError ("cannot move binary"))
exeFileName :: DynFlags -> FilePath
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1bb39666c5..675b26e2c0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1573,7 +1573,7 @@ parseDynLibLoaderMode f d =
case splitAt 8 f of
("deploy", "") -> d{ dynLibLoader = Deployable }
("sysdep", "") -> d{ dynLibLoader = SystemDependent }
- _ -> ghcError (CmdLineError ("Unknown dynlib loader: " ++ f))
+ _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))
setDumpPrefixForce f d = d { dumpPrefixForce = f}
@@ -1728,7 +1728,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let ((leftover, errs, warns), dflags1)
= runCmdLine (processArgs activeFlags args') dflags0
- when (not (null errs)) $ ghcError $ errorsToGhcException errs
+ when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
-- check for disabled flags in safe haskell
let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
@@ -1742,7 +1742,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
}
unless (allowed_combination theWays) $
- ghcError (CmdLineError ("combination not supported: " ++
+ throwGhcException (CmdLineError ("combination not supported: " ++
intercalate "/" (map wayDesc theWays)))
let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3
@@ -3273,7 +3273,7 @@ makeDynFlagsConsistent dflags
then let dflags' = dflags { hscTarget = HscAsm }
warn = "Using native code generator rather than LLVM, as LLVM is incompatible with -fPIC and -dynamic on this platform"
in loop dflags' warn
- else ghcError $ CmdLineError "Can't use -fPIC or -dynamic on this platform"
+ else throwGhcException $ CmdLineError "Can't use -fPIC or -dynamic on this platform"
| os == OSDarwin &&
arch == ArchX86_64 &&
not (gopt Opt_PIC dflags)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 82b822b309..bdfe5e660c 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -1297,7 +1297,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
err -> noModError dflags noSrcSpan mod_name err
modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
-modNotLoadedError dflags m loc = ghcError $ CmdLineError $ showSDoc dflags $
+modNotLoadedError dflags m loc = throwGhcException $ CmdLineError $ showSDoc dflags $
text "module is not loaded:" <+>
quotes (ppr (moduleName m)) <+>
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index cc51e0591c..34898a92a3 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -952,7 +952,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
-- the full set of nodes, and determining the reachable set from
-- the specified node.
let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
- | otherwise = ghcError (ProgramError "module does not exist")
+ | otherwise = throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVertices (seq root (reachableG graph root))
type SummaryNode = (ModSummary, Int, [Int])
@@ -1425,7 +1425,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
| otherwise = False
when needs_preprocessing $
- ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
+ throwGhcException (ProgramError "buffer needs preprocesing; interactive check disabled")
return (dflags', src_fn, buf)
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 9b9c14bb0b..5f7d0c7d99 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -468,7 +468,7 @@ resume canLogSpan step
resume = ic_resume ic
case resume of
- [] -> ghcError (ProgramError "not stopped at a breakpoint")
+ [] -> throwGhcException (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
-- unbind the temporary locals by restoring the TypeEnv from
-- before the breakpoint, and drop this Resume from the
@@ -525,16 +525,16 @@ moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
moveHist fn = do
hsc_env <- getSession
case ic_resume (hsc_IC hsc_env) of
- [] -> ghcError (ProgramError "not stopped at a breakpoint")
+ [] -> throwGhcException (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
let ix = resumeHistoryIx r
history = resumeHistory r
new_ix = fn ix
--
when (new_ix > length history) $
- ghcError (ProgramError "no more logged breakpoints")
+ throwGhcException (ProgramError "no more logged breakpoints")
when (new_ix < 0) $
- ghcError (ProgramError "already at the beginning of the history")
+ throwGhcException (ProgramError "already at the beginning of the history")
let
update_ic apStack mb_info = do
@@ -816,7 +816,7 @@ setContext imports
; let dflags = hsc_dflags hsc_env
; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
; case all_env_err of
- Left (mod, err) -> ghcError (formatError dflags mod err)
+ Left (mod, err) -> throwGhcException (formatError dflags mod err)
Right all_env -> do {
; let old_ic = hsc_IC hsc_env
final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 9204763ebf..1c04c2ce8e 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -230,14 +230,14 @@ readPackageConfig dflags conf_file = do
else do
isfile <- doesFileExist conf_file
when (not isfile) $
- ghcError $ InstallationError $
+ throwGhcException $ InstallationError $
"can't find a package database at " ++ conf_file
debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
str <- readFile conf_file
case reads str of
[(configs, rest)]
| all isSpace rest -> return (map installedPackageInfoToPackageConfig configs)
- _ -> ghcError $ InstallationError $
+ _ -> throwGhcException $ InstallationError $
"invalid package database file " ++ conf_file
let
@@ -410,12 +410,12 @@ packageFlagErr :: DynFlags
-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
- = ghcError (CmdLineError (showSDoc dflags $ dph_err))
+ = throwGhcException (CmdLineError (showSDoc dflags $ dph_err))
where dph_err = text "the " <> text pkg <> text " package is not installed."
$$ text "To install it: \"cabal install dph\"."
is_dph_package pkg = "dph" `isPrefixOf` pkg
-packageFlagErr dflags flag reasons = ghcError (CmdLineError (showSDoc dflags $ err))
+packageFlagErr dflags flag reasons = throwGhcException (CmdLineError (showSDoc dflags $ err))
where err = text "cannot satisfy " <> ppr_flag <>
(if null reasons then empty else text ": ") $$
nest 4 (ppr_reasons $$
@@ -983,7 +983,7 @@ closeDeps dflags pkg_map ipid_map ps
throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr dflags m
= case m of
- Failed e -> ghcError (CmdLineError (showSDoc dflags e))
+ Failed e -> throwGhcException (CmdLineError (showSDoc dflags e))
Succeeded r -> return r
closeDepsErr :: PackageConfigMap
@@ -1017,7 +1017,7 @@ add_package pkg_db ipid_map ps (p, mb_parent)
missingPackageErr :: DynFlags -> String -> IO a
missingPackageErr dflags p
- = ghcError (CmdLineError (showSDoc dflags (missingPackageMsg p)))
+ = throwGhcException (CmdLineError (showSDoc dflags (missingPackageMsg p)))
missingPackageMsg :: String -> SDoc
missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
index e2414f7f34..76454bdfa5 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -57,10 +57,10 @@ parseStaticFlagsFull :: [Flag IO] -> [Located String]
-> IO ([Located String], [Located String])
parseStaticFlagsFull flagsAvailable args = do
ready <- readIORef v_opt_C_ready
- when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")
+ when ready $ throwGhcException (ProgramError "Too late for parseStaticFlags: call it before newSession")
(leftover, errs, warns) <- processArgs flagsAvailable args
- when (not (null errs)) $ ghcError $ errorsToGhcException errs
+ when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
-- see sanity code in staticOpts
writeIORef v_opt_C_ready True
@@ -129,7 +129,7 @@ decodeSize str
| c == "K" || c == "k" = truncate (n * 1000)
| c == "M" || c == "m" = truncate (n * 1000 * 1000)
| c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
- | otherwise = ghcError (CmdLineError ("can't decode size: " ++ str))
+ | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str))
where (m, c) = span pred str
n = readRational m
pred c = isDigit c || c == '.'
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 49f0ff729b..8c514a5af3 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -135,7 +135,7 @@ try_read :: Read a => String -> String -> a
try_read sw str
= case reads str of
((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses
- [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
+ [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
-- ToDo: hack alert. We should really parse the arguments
-- and announce errors in a more civilised way.
-}
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 877bd6b4b4..f4e5f2cf0f 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 -> ghcError (InstallationError "missing -B<dir> option")
+ Nothing -> throwGhcException (InstallationError "missing -B<dir> option")
Just dir -> return dir
\end{code}
@@ -830,14 +830,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 -> ghcError (PhaseFailed phase_name rc)
+ | otherwise -> throwGhcException (PhaseFailed phase_name rc)
where
handler err =
if IO.isDoesNotExistError err
then does_not_exist
else IO.ioError err
- does_not_exist = ghcError (InstallationError ("could not execute: " ++ pgm))
+ does_not_exist = throwGhcException (InstallationError ("could not execute: " ++ pgm))
builderMainLoop :: DynFlags -> (String -> String) -> FilePath
@@ -969,7 +969,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))
- ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
+ ; throwGhcException (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
%************************************************************************
diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 3521910e95..c02de1c3de 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -10,7 +10,7 @@ some unnecessary loops in the module dependency graph.
\begin{code}
module Panic (
GhcException(..), showGhcException, throwGhcException, handleGhcException,
- ghcError, progName,
+ progName,
pgmError,
panic, sorry, panicFastInt, assertPanic, trace,
@@ -173,10 +173,6 @@ showGhcException exception
ExitFailure x -> x
--- | Alias for `throwGhcException`
-ghcError :: GhcException -> a
-ghcError e = Exception.throw e
-
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw
diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs
index 1f43328f8d..2815a74dcb 100644
--- a/ghc/GhciTags.hs
+++ b/ghc/GhciTags.hs
@@ -82,7 +82,7 @@ listModuleTags m = do
-- should we just skip these?
when (not is_interpreted) $
let mName = GHC.moduleNameString (GHC.moduleName m) in
- ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
mbModInfo <- GHC.getModuleInfo m
case mbModInfo of
Nothing -> return []
@@ -148,7 +148,7 @@ collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
tryIO (writeFile file $ concat tagGroups)
where
- processGroup [] = ghcError (CmdLineError "empty tag file group??")
+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??")
processGroup group@(tagInfo:_) =
let tags = unlines $ map showETag group in
"\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
@@ -160,7 +160,7 @@ makeTagGroupsWithSrcInfo tagInfos = do
mapM addTagSrcInfo groups
where
- addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??")
+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
addTagSrcInfo group@(tagInfo:_) = do
file <- readFile $tagFile tagInfo
let sortedGroup = sortBy (comparing tagLine) group
@@ -200,5 +200,5 @@ showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
++ "\x7f" ++ tag
++ "\x01" ++ show lineNo
++ "," ++ show charPos
-showETag _ = ghcError (CmdLineError "missing source file info in showETag")
+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 5793080a51..9c4a492b6d 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -341,7 +341,7 @@ interactiveUI config srcs maybe_exprs = do
-- this up front and emit a helpful error message (#2197)
i <- liftIO $ isProfiled
when (i /= 0) $
- ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
+ throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
@@ -1007,7 +1007,7 @@ help _ = do
-- :info
info :: String -> InputT GHCi ()
-info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
+info "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
info s = handleSourceError GHC.printException $ do
unqual <- GHC.getPrintUnqual
dflags <- getDynFlags
@@ -1105,7 +1105,7 @@ editFile str =
st <- lift getGHCiState
let cmd = editor st
when (null cmd)
- $ ghcError (CmdLineError "editor not set, use :set editor")
+ $ throwGhcException (CmdLineError "editor not set, use :set editor")
code <- liftIO $ system (cmd ++ ' ':file)
when (code == ExitSuccess)
$ reloadModule ""
@@ -1137,7 +1137,7 @@ chooseEditFile =
do targets <- GHC.getTargets
case msum (map fromTarget targets) of
Just file -> return file
- Nothing -> ghcError (CmdLineError "No files to edit.")
+ Nothing -> throwGhcException (CmdLineError "No files to edit.")
where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
fromTarget _ = Nothing -- when would we get a module target?
@@ -1160,7 +1160,7 @@ defineMacro overwrite s = do
unlines defined)
else do
if (not overwrite && macro_name `elem` defined)
- then ghcError (CmdLineError
+ then throwGhcException (CmdLineError
("macro '" ++ macro_name ++ "' is already defined"))
else do
@@ -1195,7 +1195,7 @@ undefineMacro str = mapM_ undef (words str)
where undef macro_name = do
cmds <- liftIO (readIORef macros_ref)
if (macro_name `notElem` map cmdName cmds)
- then ghcError (CmdLineError
+ then throwGhcException (CmdLineError
("macro '" ++ macro_name ++ "' is not defined"))
else do
liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
@@ -1438,14 +1438,14 @@ scriptCmd :: String -> InputT GHCi ()
scriptCmd ws = do
case words ws of
[s] -> runScript s
- _ -> ghcError (CmdLineError "syntax: :script <filename>")
+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
runScript :: String -- ^ filename
-> InputT GHCi ()
runScript filename = do
either_script <- liftIO $ tryIO (openFile filename ReadMode)
case either_script of
- Left _err -> ghcError (CmdLineError $ "IO error: \""++filename++"\" "
+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "
++(ioeGetErrorString _err))
Right script -> do
st <- lift $ getGHCiState
@@ -1477,18 +1477,18 @@ isSafeCmd m =
isSafeModule md
[] -> do md <- guessCurrentModule "issafe"
isSafeModule md
- _ -> ghcError (CmdLineError "syntax: :issafe <module>")
+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
isSafeModule :: Module -> InputT GHCi ()
isSafeModule m = do
mb_mod_info <- GHC.getModuleInfo m
when (isNothing mb_mod_info)
- (ghcError $ CmdLineError $ "unknown module: " ++ mname)
+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
dflags <- getDynFlags
let iface = GHC.modInfoIface $ fromJust mb_mod_info
when (isNothing iface)
- (ghcError $ CmdLineError $ "can't load interface file for module: " ++
+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
(GHC.moduleNameString $ GHC.moduleName m))
(msafe, pkgs) <- GHC.moduleTrustReqs m
@@ -1538,7 +1538,7 @@ browseCmd bang m =
browseModule bang md True
[] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
browseModule bang md True
- _ -> ghcError (CmdLineError "syntax: :browse <module>")
+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")
guessCurrentModule :: String -> InputT GHCi Module
-- Guess which module the user wants to browse. Pick
@@ -1546,7 +1546,7 @@ guessCurrentModule :: String -> InputT GHCi Module
-- recently-added module occurs last, it seems.
guessCurrentModule cmd
= do imports <- GHC.getContext
- when (null imports) $ ghcError $
+ when (null imports) $ throwGhcException $
CmdLineError (':' : cmd ++ ": no current module")
case (head imports) of
IIModule m -> GHC.findModule m Nothing
@@ -1563,7 +1563,7 @@ browseModule bang modl exports_only = do
mb_mod_info <- GHC.getModuleInfo modl
case mb_mod_info of
- Nothing -> ghcError (CmdLineError ("unknown module: " ++
+ Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
GHC.moduleNameString (GHC.moduleName modl)))
Just mod_info -> do
dflags <- getDynFlags
@@ -1641,7 +1641,7 @@ browseModule bang modl exports_only = do
moduleCmd :: String -> GHCi ()
moduleCmd str
| all sensible strs = cmd
- | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
where
(cmd, strs) =
case str of
@@ -1742,7 +1742,7 @@ checkAdd ii = do
let safe = safeLanguageOn dflags
case ii of
IIModule modname
- | safe -> ghcError $ CmdLineError "can't use * imports with Safe Haskell"
+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
| otherwise -> wantInterpretedModuleName modname >> return ()
IIDecl d -> do
@@ -1751,7 +1751,7 @@ checkAdd ii = do
m <- GHC.lookupModule modname pkgqual
when safe $ do
t <- GHC.isModuleTrusted m
- when (not t) $ ghcError $ ProgramError $ ""
+ when (not t) $ throwGhcException $ ProgramError $ ""
-- -----------------------------------------------------------------------------
-- Update the GHC API's view of the context
@@ -2002,7 +2002,7 @@ newDynFlags interactive_only minus_opts = do
liftIO $ handleFlagWarnings idflags1 warns
when (not $ null leftovers)
- (ghcError . CmdLineError
+ (throwGhcException . CmdLineError
$ "Some flags have not been recognized: "
++ (concat . intersperse ", " $ map unLoc leftovers))
@@ -2056,7 +2056,7 @@ unsetOptions str
]
no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
- no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
in if (not (null rest3))
then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
@@ -2128,7 +2128,7 @@ showCmd str = do
["languages"] -> showLanguages -- backwards compat
["language"] -> showLanguages
["lang"] -> showLanguages -- useful abbreviation
- _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
+ _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
" | breaks | context | packages | language ]"))
showiCmd :: String -> GHCi ()
@@ -2137,7 +2137,7 @@ showiCmd str = do
["languages"] -> showiLanguages -- backwards compat
["language"] -> showiLanguages
["lang"] -> showiLanguages -- useful abbreviation
- _ -> ghcError (CmdLineError ("syntax: :showi language"))
+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
showImports :: GHCi ()
showImports = do
@@ -2585,7 +2585,7 @@ breakByModuleLine md line args
| otherwise = breakSyntax
breakSyntax :: a
-breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
findBreakAndSet md lookupTickTree = do
@@ -2987,10 +2987,10 @@ wantInterpretedModuleName modname = do
let str = moduleNameString modname
dflags <- getDynFlags
when (GHC.modulePackageId modl /= thisPackage dflags) $
- ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
is_interpreted <- GHC.moduleIsInterpreted modl
when (not is_interpreted) $
- ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
return modl
wantNameFromInterpretedModule :: GHC.GhcMonad m
diff --git a/ghc/Main.hs b/ghc/Main.hs
index a84f2ac140..05a986daae 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -222,7 +222,7 @@ main' postLoadMode dflags0 args flagWarnings = do
ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
#ifndef GHCI
-ghciUI _ _ = ghcError (CmdLineError "not built for interactive use")
+ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
#else
ghciUI = interactiveUI defaultGhciSettings
#endif
@@ -293,18 +293,18 @@ checkOptions mode dflags srcs objs = do
-- -prof and --interactive are not a good combination
when ((filter (not . wayRTSOnly) (ways dflags) /= defaultWays (settings dflags))
&& isInterpretiveMode mode) $
- do ghcError (UsageError
+ do throwGhcException (UsageError
"--interactive can't be used with -prof or -unreg.")
-- -ohi sanity check
if (isJust (outputHi dflags) &&
(isCompManagerMode mode || srcs `lengthExceeds` 1))
- then ghcError (UsageError "-ohi can only be used when compiling a single source file")
+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
else do
-- -o sanity checking
if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
&& not (isLinkMode mode))
- then ghcError (UsageError "can't apply -o to multiple source files")
+ then throwGhcException (UsageError "can't apply -o to multiple source files")
else do
let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
@@ -315,7 +315,7 @@ checkOptions mode dflags srcs objs = do
-- Check that there are some input files
-- (except in the interactive case)
if null srcs && (null objs || not_linking) && needsInputsMode mode
- then ghcError (UsageError "no input files")
+ then throwGhcException (UsageError "no input files")
else do
-- Verify that output files point somewhere sensible.
@@ -346,7 +346,7 @@ verifyOutputFiles dflags = do
when (not flg) (nonExistentDir "-ohi" hi)
where
nonExistentDir flg dir =
- ghcError (CmdLineError ("error: directory portion of " ++
+ throwGhcException (CmdLineError ("error: directory portion of " ++
show dir ++ " does not exist (used with " ++
show flg ++ " option.)"))
@@ -492,7 +492,7 @@ parseModeFlags args = do
Nothing -> doMakeMode
Just (m, _) -> m
errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
- when (not (null errs)) $ ghcError $ errorsToGhcException errs
+ when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
return (mode, flags' ++ leftover, warns)
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
@@ -768,7 +768,7 @@ abiHash strs = do
r <- findImportedModule hsc_env modname Nothing
case r of
Found _ m -> return m
- _error -> ghcError $ CmdLineError $ showSDoc dflags $
+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $
cannotFindInterface dflags modname r
mods <- mapM find_it (map fst strs)
@@ -789,7 +789,7 @@ abiHash strs = do
-- Util
unknownFlagsErr :: [String] -> a
-unknownFlagsErr fs = ghcError $ UsageError $ concatMap oneError fs
+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
where
oneError f =
"unrecognised flag: " ++ f ++ "\n" ++
View Lorry Controller Status