Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
77ef6ca0
Commit
77ef6ca0
authored
Nov 29, 2012
by
Erik de Castro Lopo
Browse files
Replace all uses of ghcError with throwGhcException and purge ghcError.
parent
086d7c54
Changes
21
Hide whitespace changes
Inline
Side-by-side
compiler/ghci/ByteCodeGen.lhs
View file @
77ef6ca0
...
...
@@ -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"++
...
...
compiler/ghci/ByteCodeLink.lhs
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/ghci/LibFFI.hsc
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/ghci/Linker.lhs
View file @
77ef6ca0
...
...
@@ -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.
...
...
compiler/iface/BinIface.hs
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/iface/LoadIface.lhs
View file @
77ef6ca0
...
...
@@ -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 }
------------------
...
...
compiler/iface/MkIface.lhs
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/main/DriverMkDepend.hs
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/main/DriverPipeline.hs
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/main/DynFlags.hs
View file @
77ef6ca0
...
...
@@ -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
)
...
...
compiler/main/GHC.hs
View file @
77ef6ca0
...
...
@@ -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
)))
...
...
compiler/main/GhcMake.hs
View file @
77ef6ca0
...
...
@@ -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
)
...
...
compiler/main/InteractiveEval.hs
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/main/Packages.lhs
View file @
77ef6ca0
...
...
@@ -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
...
...
compiler/main/StaticFlagParser.hs
View file @
77ef6ca0
...
...
@@ -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
==
'.'
...
...
compiler/main/StaticFlags.hs
View file @
77ef6ca0
...
...
@@ -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.
-}
...
...
compiler/main/SysTools.lhs
View file @
77ef6ca0
...
...
@@ -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}
%************************************************************************
...
...
compiler/utils/Panic.lhs
View file @
77ef6ca0
...
...
@@ -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
...
...
ghc/GhciTags.hs
View file @
77ef6ca0
...
...
@@ -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"
)
ghc/InteractiveUI.hs
View file @
77ef6ca0
...
...
@@ -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