Skip to content
GitLab
Menu
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
fc9bbbab
Commit
fc9bbbab
authored
Aug 26, 2008
by
Ian Lynagh
Browse files
Give locations of flag warnings/errors
parent
54280054
Changes
10
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/SrcLoc.lhs
View file @
fc9bbbab
...
...
@@ -58,6 +58,7 @@ module SrcLoc (
-- ** Constructing Located
noLoc,
mkGeneralLocated,
-- ** Deconstructing Located
getLoc, unLoc,
...
...
@@ -453,6 +454,9 @@ getLoc (L l _) = l
noLoc :: e -> Located e
noLoc e = L noSrcSpan e
mkGeneralLocated :: String -> e -> Located e
mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
combineLocs :: Located a -> Located b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
...
...
compiler/ghci/InteractiveUI.hs
View file @
fc9bbbab
...
...
@@ -42,6 +42,7 @@ import SrcLoc
-- Other random utilities
import
ErrUtils
import
CmdLineParser
import
Digraph
import
BasicTypes
hiding
(
isTopLevel
)
import
Panic
hiding
(
showException
)
...
...
@@ -1503,13 +1504,12 @@ newDynFlags :: [String] -> GHCi ()
newDynFlags
minus_opts
=
do
dflags
<-
getDynFlags
let
pkg_flags
=
packageFlags
dflags
(
dflags'
,
leftovers
,
warns
)
<-
io
$
GHC
.
parseDynamicFlags
dflags
minus_opts
(
dflags'
,
leftovers
,
warns
)
<-
io
$
GHC
.
parseDynamicFlags
dflags
$
map
noLoc
minus_opts
io
$
handleFlagWarnings
dflags'
warns
if
(
not
(
null
leftovers
))
then
ghcError
(
CmdLineError
(
"unrecognised flags: "
++
unwords
leftovers
))
else
return
()
then
ghcError
$
errorsToGhcException
leftovers
else
return
()
new_pkgs
<-
setDynFlags
dflags'
...
...
compiler/main/CmdLineParser.hs
View file @
fc9bbbab
...
...
@@ -13,12 +13,15 @@ module CmdLineParser (
processArgs
,
OptKind
(
..
),
CmdLineP
(
..
),
getCmdLineState
,
putCmdLineState
,
Flag
(
..
),
Deprecated
(
..
),
errorsToGhcException
)
where
#
include
"HsVersions.h"
import
Util
import
Outputable
import
Panic
import
SrcLoc
data
Flag
m
=
Flag
{
...
...
@@ -44,36 +47,36 @@ data OptKind m -- Suppose the flag is -f
processArgs
::
Monad
m
=>
[
Flag
m
]
-- cmdline parser spec
->
[
String
]
-- args
->
[
Located
String
]
-- args
->
m
(
[
String
],
-- spare args
[
String
],
-- errors
[
String
]
-- warnings
[
Located
String
],
-- spare args
[
Located
String
],
-- errors
[
Located
String
]
-- warnings
)
processArgs
spec
args
=
process
spec
args
[]
[]
[]
where
process
_spec
[]
spare
errs
warns
=
return
(
reverse
spare
,
reverse
errs
,
reverse
warns
)
process
spec
(
dash_arg
@
(
'-'
:
arg
)
:
args
)
spare
errs
warns
=
process
spec
(
locArg
@
(
L
loc
dash_arg
@
(
'-'
:
arg
)
)
:
args
)
spare
errs
warns
=
case
findArg
spec
arg
of
Just
(
rest
,
action
,
deprecated
)
->
let
warns'
=
case
deprecated
of
Deprecated
warning
->
(
"Warning: "
++
dash_arg
++
" is deprecated: "
++
warning
)
:
warns
L
loc
(
"Warning: "
++
dash_arg
++
" is deprecated: "
++
warning
)
:
warns
Supported
->
warns
in
case
processOneArg
action
rest
arg
args
of
Left
err
->
process
spec
args
spare
(
err
:
errs
)
warns'
Left
err
->
process
spec
args
spare
(
L
loc
err
:
errs
)
warns'
Right
(
action
,
rest
)
->
do
action
process
spec
rest
spare
errs
warns'
Nothing
->
process
spec
args
(
dash_a
rg
:
spare
)
errs
warns
Nothing
->
process
spec
args
(
locA
rg
:
spare
)
errs
warns
process
spec
(
arg
:
args
)
spare
errs
warns
=
process
spec
args
(
arg
:
spare
)
errs
warns
processOneArg
::
OptKind
m
->
String
->
String
->
[
String
]
->
Either
String
(
m
()
,
[
String
])
processOneArg
::
OptKind
m
->
String
->
String
->
[
Located
String
]
->
Either
String
(
m
()
,
[
Located
String
])
processOneArg
action
rest
arg
args
=
let
dash_arg
=
'-'
:
arg
rest_no_eq
=
dropEq
rest
...
...
@@ -83,11 +86,11 @@ processOneArg action rest arg args
HasArg
f
|
notNull
rest_no_eq
->
Right
(
f
rest_no_eq
,
args
)
|
otherwise
->
case
args
of
[]
->
missingArgErr
dash_arg
(
arg1
:
args1
)
->
Right
(
f
arg1
,
args1
)
(
L
_
arg1
:
args1
)
->
Right
(
f
arg1
,
args1
)
SepArg
f
->
case
args
of
[]
->
unknownFlagErr
dash_arg
(
arg1
:
args1
)
->
Right
(
f
arg1
,
args1
)
(
L
_
arg1
:
args1
)
->
Right
(
f
arg1
,
args1
)
Prefix
f
|
notNull
rest_no_eq
->
Right
(
f
rest_no_eq
,
args
)
|
otherwise
->
unknownFlagErr
dash_arg
...
...
@@ -168,3 +171,12 @@ getCmdLineState :: CmdLineP s s
getCmdLineState
=
CmdLineP
$
\
s
->
(
s
,
s
)
putCmdLineState
::
s
->
CmdLineP
s
()
putCmdLineState
s
=
CmdLineP
$
\
_
->
(
()
,
s
)
-- ---------------------------------------------------------------------
-- Utils
errorsToGhcException
::
[
Located
String
]
->
GhcException
errorsToGhcException
errs
=
let
errors
=
vcat
[
ppr
l
<>
text
": "
<>
text
e
|
L
l
e
<-
errs
]
in
UsageError
(
showSDoc
errors
)
compiler/main/DriverPipeline.hs
View file @
fc9bbbab
...
...
@@ -46,8 +46,7 @@ import StringBuffer ( hGetStringBuffer )
import
BasicTypes
(
SuccessFlag
(
..
)
)
import
Maybes
(
expectJust
)
import
ParserCoreUtils
(
getCoreModuleName
)
import
SrcLoc
(
unLoc
)
import
SrcLoc
(
Located
(
..
)
)
import
SrcLoc
import
FastString
import
Exception
...
...
@@ -616,12 +615,12 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
-- Cpp phase : (a) gets OPTIONS out of file
-- (b) runs cpp if necessary
runPhase
(
Cpp
sf
)
_stop
hsc_env
basename
suff
input_fn
get_output_fn
maybe_loc
runPhase
(
Cpp
sf
)
_stop
hsc_env
_
basename
_
suff
input_fn
get_output_fn
maybe_loc
=
do
let
dflags0
=
hsc_dflags
hsc_env
src_opts
<-
getOptionsFromFile
dflags0
input_fn
(
dflags
,
unhandled_flags
,
warns
)
<-
parseDynamicFlags
dflags0
(
map
unLoc
src_opts
)
(
dflags
,
unhandled_flags
,
warns
)
<-
parseDynamicFlags
dflags0
src_opts
handleFlagWarnings
dflags
warns
checkProcessArgsResult
unhandled_flags
(
basename
<.>
suff
)
checkProcessArgsResult
unhandled_flags
if
not
(
dopt
Opt_Cpp
dflags
)
then
-- no need to preprocess CPP, just pass input file along
...
...
compiler/main/DynFlags.hs
View file @
fc9bbbab
...
...
@@ -83,7 +83,7 @@ import Panic
import
UniqFM
(
UniqFM
)
import
Util
import
Maybes
(
orElse
)
import
SrcLoc
(
SrcSpan
)
import
SrcLoc
import
FastString
import
Outputable
import
{-#
SOURCE
#-
}
ErrUtils
(
Severity
(
..
),
Message
,
mkLocMessage
)
...
...
@@ -1690,7 +1690,8 @@ glasgowExtsFlags = [
-- -----------------------------------------------------------------------------
-- Parsing the dynamic flags.
parseDynamicFlags
::
DynFlags
->
[
String
]
->
IO
(
DynFlags
,
[
String
],
[
String
])
parseDynamicFlags
::
DynFlags
->
[
Located
String
]
->
IO
(
DynFlags
,
[
Located
String
],
[
Located
String
])
parseDynamicFlags
dflags
args
=
do
-- XXX Legacy support code
-- We used to accept things like
...
...
@@ -1699,14 +1700,13 @@ parseDynamicFlags dflags args = do
-- optdep -f -optdepdepend
-- optdep -f -optdep depend
-- but the spaces trip up proper argument handling. So get rid of them.
let
f
(
"-optdep"
:
x
:
xs
)
=
(
"-optdep"
++
x
)
:
f
xs
let
f
(
L
p
"-optdep"
:
L
_
x
:
xs
)
=
(
L
p
(
"-optdep"
++
x
)
)
:
f
xs
f
(
x
:
xs
)
=
x
:
f
xs
f
xs
=
xs
args'
=
f
args
let
((
leftover
,
errs
,
warns
),
dflags'
)
=
runCmdLine
(
processArgs
dynamic_flags
args'
)
dflags
when
(
not
(
null
errs
))
$
do
ghcError
(
UsageError
(
unlines
errs
))
when
(
not
(
null
errs
))
$
ghcError
$
errorsToGhcException
errs
return
(
dflags'
,
leftover
,
warns
)
type
DynP
=
CmdLineP
DynFlags
...
...
compiler/main/ErrUtils.lhs
View file @
fc9bbbab
...
...
@@ -32,10 +32,9 @@ module ErrUtils (
#include "HsVersions.h"
import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcSpan )
import Util ( sortLe )
import Outputable
import SrcLoc
( srcSpanStart, noSrcSpan )
import SrcLoc
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
...
...
@@ -197,22 +196,25 @@ printBagOfWarnings dflags bag_of_warns
EQ -> True
GT -> False
handleFlagWarnings :: DynFlags -> [String] -> IO ()
handleFlagWarnings :: DynFlags -> [
Located
String] -> IO ()
handleFlagWarnings dflags warns
= when (dopt Opt_WarnDeprecatedFlags dflags)
(handleFlagWarnings' dflags warns)
handleFlagWarnings' :: DynFlags -> [String] -> IO ()
handleFlagWarnings' :: DynFlags -> [
Located
String] -> IO ()
handleFlagWarnings' _ [] = return ()
handleFlagWarnings' dflags warns
= do -- It would be nicer if warns :: [Message], but that has circular
= do -- It would be nicer if warns :: [
Located
Message], but that has circular
-- import problems.
let warns' = map text warns
mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
mapM_ (handleFlagWarning dflags) warns
when (dopt Opt_WarnIsError dflags) $
do errorMsg dflags $ text "\nFailing due to -Werror.\n"
exitWith (ExitFailure 1)
handleFlagWarning :: DynFlags -> Located String -> IO ()
handleFlagWarning dflags (L loc warn)
= log_action dflags SevWarning loc defaultUserStyle (text warn)
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
| val == 0 = exitWith ExitSuccess
...
...
compiler/main/GHC.hs
View file @
fc9bbbab
...
...
@@ -2000,8 +2000,8 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
let
local_opts
=
getOptions
dflags
buf
src_fn
--
(
dflags'
,
leftovers
,
warns
)
<-
parseDynamicFlags
dflags
(
map
unLoc
local_opts
)
checkProcessArgsResult
leftovers
src_fn
(
dflags'
,
leftovers
,
warns
)
<-
parseDynamicFlags
dflags
local_opts
checkProcessArgsResult
leftovers
handleFlagWarnings
dflags'
warns
let
...
...
compiler/main/HeaderInfo.hs
View file @
fc9bbbab
...
...
@@ -185,13 +185,14 @@ getOptions' dflags buf filename
-----------------------------------------------------------------------------
-- Complain about non-dynamic flags in OPTIONS pragmas
checkProcessArgsResult
::
[
String
]
->
FilePath
->
IO
()
checkProcessArgsResult
flags
filename
=
do
when
(
notNull
flags
)
(
ghcError
(
ProgramError
(
showSDoc
(
hang
(
text
filename
<>
char
':'
)
4
(
text
"unknown flags in {-# OPTIONS #-} pragma:"
<+>
hsep
(
map
text
flags
)))
)))
checkProcessArgsResult
::
[
Located
String
]
->
IO
()
checkProcessArgsResult
flags
=
when
(
notNull
flags
)
$
ghcError
$
ProgramError
$
showSDoc
$
vcat
$
map
f
flags
where
f
(
L
loc
flag
)
=
hang
(
ppr
loc
<>
char
':'
)
4
(
text
"unknown flag in {-# OPTIONS #-} pragma:"
<+>
text
flag
)
-----------------------------------------------------------------------------
...
...
compiler/main/StaticFlagParser.hs
View file @
fc9bbbab
...
...
@@ -16,6 +16,7 @@ module StaticFlagParser (parseStaticFlags) where
import
StaticFlags
import
CmdLineParser
import
Config
import
SrcLoc
import
Util
import
Panic
...
...
@@ -27,23 +28,24 @@ import Data.List
-----------------------------------------------------------------------------
-- Static flags
parseStaticFlags
::
[
String
]
->
IO
([
String
],
[
String
])
parseStaticFlags
::
[
Located
String
]
->
IO
([
Located
String
],
[
Located
String
])
parseStaticFlags
args
=
do
ready
<-
readIORef
v_opt_C_ready
when
ready
$
ghcError
(
ProgramError
"Too late for parseStaticFlags: call it before newSession"
)
(
leftover
,
errs
,
warns1
)
<-
processArgs
static_flags
args
when
(
not
(
null
errs
))
$
ghcError
(
UsageError
(
unlines
errs
))
when
(
not
(
null
errs
))
$
ghcError
$
errorsToGhcException
errs
-- deal with the way flags: the way (eg. prof) gives rise to
-- further flags, some of which might be static.
way_flags
<-
findBuildTag
let
way_flags'
=
map
(
mkGeneralLocated
"in way flags"
)
way_flags
-- if we're unregisterised, add some more flags
let
unreg_flags
|
cGhcUnregisterised
==
"YES"
=
unregFlags
|
otherwise
=
[]
(
more_leftover
,
errs
,
warns2
)
<-
processArgs
static_flags
(
unreg_flags
++
way_flags
)
(
more_leftover
,
errs
,
warns2
)
<-
processArgs
static_flags
(
unreg_flags
++
way_flags
'
)
-- see sanity code in staticOpts
writeIORef
v_opt_C_ready
True
...
...
@@ -52,16 +54,19 @@ parseStaticFlags args = do
-- Be careful to do this *after* all processArgs,
-- because evaluating tablesNextToCode involves looking at the global
-- static flags. Those pesky global variables...
let
cg_flags
|
tablesNextToCode
=
[
"-optc-DTABLES_NEXT_TO_CODE"
]
|
otherwise
=
[]
let
cg_flags
|
tablesNextToCode
=
map
(
mkGeneralLocated
"in cg_flags"
)
[
"-optc-DTABLES_NEXT_TO_CODE"
]
|
otherwise
=
[]
-- HACK: -fexcess-precision is both a static and a dynamic flag. If
-- the static flag parser has slurped it, we must return it as a
-- leftover too. ToDo: make -fexcess-precision dynamic only.
let
excess_prec
|
opt_SimplExcessPrecision
=
[
"-fexcess-precision"
]
|
otherwise
=
[]
let
excess_prec
|
opt_SimplExcessPrecision
=
map
(
mkGeneralLocated
"in excess_prec"
)
[
"-fexcess-precision"
]
|
otherwise
=
[]
when
(
not
(
null
errs
))
$
ghcError
(
UsageError
(
unlines
errs
))
when
(
not
(
null
errs
))
$
ghcError
$
errorsToGhcException
errs
return
(
excess_prec
++
cg_flags
++
more_leftover
++
leftover
,
warns1
++
warns2
)
...
...
@@ -181,8 +186,8 @@ isStaticFlag f =
"funfolding-keeness-factor"
]
unregFlags
::
[
String
]
unregFlags
=
unregFlags
::
[
Located
String
]
unregFlags
=
map
(
mkGeneralLocated
"in unregFlags"
)
[
"-optc-DNO_REGS"
,
"-optc-DUSE_MINIINTERPRETER"
,
"-fno-asm-mangling"
...
...
ghc/Main.hs
View file @
fc9bbbab
...
...
@@ -41,6 +41,7 @@ import BasicTypes ( failed )
import
ErrUtils
import
FastString
import
Outputable
import
SrcLoc
import
Util
import
Panic
...
...
@@ -77,7 +78,8 @@ main =
mbMinusB
|
null
minusB_args
=
Nothing
|
otherwise
=
Just
(
drop
2
(
last
minusB_args
))
(
argv2
,
staticFlagWarnings
)
<-
parseStaticFlags
argv1
let
argv1'
=
map
(
mkGeneralLocated
"on the commandline"
)
argv1
(
argv2
,
staticFlagWarnings
)
<-
parseStaticFlags
argv1'
-- 2. Parse the "mode" flags (--make, --interactive etc.)
(
cli_mode
,
argv3
,
modeFlagWarnings
)
<-
parseModeFlags
argv2
...
...
@@ -156,7 +158,7 @@ main =
-- To simplify the handling of filepaths, we normalise all filepaths right
-- away - e.g., for win32 platforms, backslashes are converted
-- into forward slashes.
normal_fileish_paths
=
map
normalise
fileish_args
normal_fileish_paths
=
map
(
normalise
.
unLoc
)
fileish_args
(
srcs
,
objs
)
=
partition_args
normal_fileish_paths
[]
[]
-- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
...
...
@@ -362,15 +364,15 @@ isCompManagerMode _ = False
-- -----------------------------------------------------------------------------
-- Parsing the mode flag
parseModeFlags
::
[
String
]
->
IO
(
CmdLineMode
,
[
String
],
[
String
])
parseModeFlags
::
[
Located
String
]
->
IO
(
CmdLineMode
,
[
Located
String
],
[
Located
String
])
parseModeFlags
args
=
do
let
((
leftover
,
errs
,
warns
),
(
mode
,
_
,
flags'
))
=
runCmdLine
(
processArgs
mode_flags
args
)
(
StopBefore
StopLn
,
""
,
[]
)
when
(
not
(
null
errs
))
$
do
ghcError
(
UsageError
(
unlines
errs
))
when
(
not
(
null
errs
))
$
ghcError
$
errorsToGhcException
errs
return
(
mode
,
flags'
++
leftover
,
warns
)
type
ModeM
=
CmdLineP
(
CmdLineMode
,
String
,
[
String
])
type
ModeM
=
CmdLineP
(
CmdLineMode
,
String
,
[
Located
String
])
-- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
-- so we collect the new ones and return them.
...
...
@@ -441,7 +443,8 @@ updateMode f flag = do
addFlag
::
String
->
ModeM
()
addFlag
s
=
do
(
m
,
f
,
flags'
)
<-
getCmdLineState
putCmdLineState
(
m
,
f
,
s
:
flags'
)
-- XXX Can we get a useful Loc?
putCmdLineState
(
m
,
f
,
mkGeneralLocated
"addFlag"
s
:
flags'
)
-- ----------------------------------------------------------------------------
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment