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
a7f88c2f
Commit
a7f88c2f
authored
Jun 14, 2008
by
Ian Lynagh
Browse files
Allow flags to be marked as deprecated
parent
f586a36d
Changes
9
Expand all
Hide whitespace changes
Inline
Side-by-side
compiler/ghci/InteractiveUI.hs
View file @
a7f88c2f
...
...
@@ -38,6 +38,7 @@ import Name
import
SrcLoc
-- Other random utilities
import
ErrUtils
import
Digraph
import
BasicTypes
hiding
(
isTopLevel
)
import
Panic
hiding
(
showException
)
...
...
@@ -1487,7 +1488,8 @@ newDynFlags :: [String] -> GHCi ()
newDynFlags
minus_opts
=
do
dflags
<-
getDynFlags
let
pkg_flags
=
packageFlags
dflags
(
dflags'
,
leftovers
)
<-
io
$
GHC
.
parseDynamicFlags
dflags
minus_opts
(
dflags'
,
leftovers
,
warns
)
<-
io
$
GHC
.
parseDynamicFlags
dflags
minus_opts
io
$
handleFlagWarnings
dflags'
warns
if
(
not
(
null
leftovers
))
then
throwDyn
(
CmdLineError
(
"unrecognised flags: "
++
...
...
compiler/main/CmdLineParser.hs
View file @
a7f88c2f
...
...
@@ -12,7 +12,7 @@
module
CmdLineParser
(
processArgs
,
OptKind
(
..
),
CmdLineP
(
..
),
getCmdLineState
,
putCmdLineState
,
Flag
(
..
),
Flag
(
..
),
Deprecated
(
..
),
)
where
#
include
"HsVersions.h"
...
...
@@ -20,9 +20,14 @@ module CmdLineParser (
import
Util
import
Panic
data
Flag
m
=
Flag
{
flagName
::
String
,
-- flag, without the leading -
flagOptKind
::
(
OptKind
m
)
-- What to do if we see it
}
data
Flag
m
=
Flag
{
flagName
::
String
,
-- flag, without the leading -
flagOptKind
::
(
OptKind
m
),
-- what to do if we see it
flagDeprecated
::
Deprecated
-- is the flag deprecated?
}
data
Deprecated
=
Supported
|
Deprecated
String
data
OptKind
m
-- Suppose the flag is -f
=
NoArg
(
m
()
)
-- -f all by itself
...
...
@@ -42,23 +47,29 @@ processArgs :: Monad m
->
[
String
]
-- args
->
m
(
[
String
],
-- spare args
[
String
]
-- errors
[
String
],
-- errors
[
String
]
-- warnings
)
processArgs
spec
args
=
process
spec
args
[]
[]
processArgs
spec
args
=
process
spec
args
[]
[]
[]
where
process
_spec
[]
spare
errs
=
return
(
reverse
spare
,
reverse
errs
)
process
_spec
[]
spare
errs
warns
=
return
(
reverse
spare
,
reverse
errs
,
reverse
warns
)
process
spec
(
dash_arg
@
(
'-'
:
arg
)
:
args
)
spare
errs
=
process
spec
(
dash_arg
@
(
'-'
:
arg
)
:
args
)
spare
errs
warns
=
case
findArg
spec
arg
of
Just
(
rest
,
action
)
->
case
processOneArg
action
rest
arg
args
of
Left
err
->
process
spec
args
spare
(
err
:
errs
)
Right
(
action
,
rest
)
->
action
>>
process
spec
rest
spare
errs
Nothing
->
process
spec
args
(
dash_arg
:
spare
)
errs
Just
(
rest
,
action
,
deprecated
)
->
let
warns'
=
case
deprecated
of
Deprecated
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'
Right
(
action
,
rest
)
->
do
action
process
spec
rest
spare
errs
warns'
Nothing
->
process
spec
args
(
dash_arg
:
spare
)
errs
warns
process
spec
(
arg
:
args
)
spare
errs
=
process
spec
args
(
arg
:
spare
)
errs
process
spec
(
arg
:
args
)
spare
errs
warns
=
process
spec
args
(
arg
:
spare
)
errs
warns
processOneArg
::
OptKind
m
->
String
->
String
->
[
String
]
...
...
@@ -99,9 +110,9 @@ processOneArg action rest arg args
AnySuffixPred
_
f
->
Right
(
f
dash_arg
,
args
)
findArg
::
[
Flag
m
]
->
String
->
Maybe
(
String
,
OptKind
m
)
findArg
::
[
Flag
m
]
->
String
->
Maybe
(
String
,
OptKind
m
,
Deprecated
)
findArg
spec
arg
=
case
[
(
removeSpaces
rest
,
optKind
)
=
case
[
(
removeSpaces
rest
,
optKind
,
flagDeprecated
flag
)
|
flag
<-
spec
,
let
optKind
=
flagOptKind
flag
,
Just
rest
<-
[
maybePrefixMatch
(
flagName
flag
)
arg
],
...
...
compiler/main/DriverMkDepend.hs
View file @
a7f88c2f
...
...
@@ -398,14 +398,20 @@ depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
dep_opts
::
[
Flag
IO
]
dep_opts
=
[
Flag
"s"
(
SepArg
(
consIORef
v_Dep_suffixes
))
Supported
,
Flag
"f"
(
SepArg
(
writeIORef
v_Dep_makefile
))
Supported
,
Flag
"w"
(
NoArg
(
writeIORef
v_Dep_warnings
False
))
Supported
,
Flag
"-include-prelude"
(
NoArg
(
writeIORef
v_Dep_include_pkg_deps
True
))
-- -include-prelude is the old name for -include-pkg-deps, kept around
-- for backward compatibility, but undocumented
(
Deprecated
"Use --include-pkg-deps instead"
)
,
Flag
"-include-pkg-deps"
(
NoArg
(
writeIORef
v_Dep_include_pkg_deps
True
))
Supported
,
Flag
"-exclude-module="
(
Prefix
(
consIORef
v_Dep_exclude_mods
.
mkModuleName
))
Supported
,
Flag
"x"
(
Prefix
(
consIORef
v_Dep_exclude_mods
.
mkModuleName
))
Supported
]
compiler/main/DriverPipeline.hs
View file @
a7f88c2f
...
...
@@ -614,7 +614,8 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
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
)
<-
parseDynamicFlags
dflags0
(
map
unLoc
src_opts
)
(
dflags
,
unhandled_flags
,
warns
)
<-
parseDynamicFlags
dflags0
(
map
unLoc
src_opts
)
handleFlagWarnings
dflags
warns
checkProcessArgsResult
unhandled_flags
(
basename
<.>
suff
)
if
not
(
dopt
Opt_Cpp
dflags
)
then
...
...
compiler/main/DynFlags.hs
View file @
a7f88c2f
This diff is collapsed.
Click to expand it.
compiler/main/ErrUtils.lhs
View file @
a7f88c2f
...
...
@@ -13,6 +13,7 @@ module ErrUtils (
Messages, errorsFound, emptyMessages,
mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
handleFlagWarnings,
ghcExit,
doIfSet, doIfSet_dyn,
...
...
@@ -174,7 +175,16 @@ printBagOfWarnings dflags bag_of_warns
EQ -> True
GT -> False
handleFlagWarnings :: DynFlags -> [String] -> IO ()
handleFlagWarnings _ [] = return ()
handleFlagWarnings dflags warns
= do -- It would be nicer if warns :: [Message], but that has circular
-- import problems.
let warns' = map text warns
mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
when (dopt Opt_WarnIsError dflags) $
do errorMsg dflags $ text "\nFailing due to -Werror.\n"
exitWith (ExitFailure 1)
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
...
...
compiler/main/GHC.hs
View file @
a7f88c2f
...
...
@@ -255,10 +255,7 @@ import FiniteMap
import
Panic
import
Digraph
import
Bag
(
unitBag
,
listToBag
)
import
ErrUtils
(
Severity
(
..
),
showPass
,
fatalErrorMsg
,
debugTraceMsg
,
mkPlainErrMsg
,
printBagOfErrors
,
printBagOfWarnings
,
WarnMsg
)
import
qualified
ErrUtils
import
ErrUtils
import
Util
import
StringBuffer
(
StringBuffer
,
hGetStringBuffer
)
import
Outputable
...
...
@@ -1938,8 +1935,9 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
let
local_opts
=
getOptions
dflags
buf
src_fn
--
(
dflags'
,
_errs
)
<-
parseDynamicFlags
dflags
(
map
unLoc
local_opts
)
(
dflags'
,
_errs
,
warns
)
<-
parseDynamicFlags
dflags
(
map
unLoc
local_opts
)
-- XXX: shouldn't we be reporting the errors?
handleFlagWarnings
dflags'
warns
let
needs_preprocessing
...
...
compiler/main/Main.hs
View file @
a7f88c2f
...
...
@@ -37,7 +37,7 @@ import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
import
StaticFlags
import
DynFlags
import
BasicTypes
(
failed
)
import
ErrUtils
(
putMsg
)
import
ErrUtils
import
FastString
import
Outputable
import
Util
...
...
@@ -78,10 +78,10 @@ main =
mbMinusB
|
null
minusB_args
=
Nothing
|
otherwise
=
Just
(
drop
2
(
last
minusB_args
))
argv2
<-
parseStaticFlags
argv1
(
argv2
,
staticFlagWarnings
)
<-
parseStaticFlags
argv1
-- 2. Parse the "mode" flags (--make, --interactive etc.)
(
cli_mode
,
argv3
)
<-
parseModeFlags
argv2
(
cli_mode
,
argv3
,
modeFlagWarnings
)
<-
parseModeFlags
argv2
-- If all we want to do is to show the version number then do it
-- now, before we start a GHC session etc.
...
...
@@ -129,7 +129,12 @@ main =
-- The rest of the arguments are "dynamic"
-- Leftover ones are presumably files
(
dflags
,
fileish_args
)
<-
GHC
.
parseDynamicFlags
dflags1
argv3
(
dflags
,
fileish_args
,
dynamicFlagWarnings
)
<-
GHC
.
parseDynamicFlags
dflags1
argv3
let
flagWarnings
=
staticFlagWarnings
++
modeFlagWarnings
++
dynamicFlagWarnings
handleFlagWarnings
dflags
flagWarnings
-- make sure we clean up after ourselves
GHC
.
defaultCleanupHandler
dflags
$
do
...
...
@@ -355,13 +360,13 @@ isCompManagerMode _ = False
-- -----------------------------------------------------------------------------
-- Parsing the mode flag
parseModeFlags
::
[
String
]
->
IO
(
CmdLineMode
,
[
String
])
parseModeFlags
::
[
String
]
->
IO
(
CmdLineMode
,
[
String
],
[
String
])
parseModeFlags
args
=
do
let
((
leftover
,
errs
),
(
mode
,
_
,
flags
))
=
let
((
leftover
,
errs
,
warns
),
(
mode
,
_
,
flags
))
=
runCmdLine
(
processArgs
mode_flags
args
)
(
StopBefore
StopLn
,
""
,
[]
)
when
(
not
(
null
errs
))
$
do
throwDyn
(
UsageError
(
unlines
errs
))
return
(
mode
,
flags
++
leftover
)
return
(
mode
,
flags
++
leftover
,
warns
)
type
ModeM
=
CmdLineP
(
CmdLineMode
,
String
,
[
String
])
-- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
...
...
@@ -371,32 +376,49 @@ mode_flags :: [Flag ModeM]
mode_flags
=
[
------- help / version ----------------------------------------------
Flag
"?"
(
PassFlag
(
setMode
ShowUsage
))
Supported
,
Flag
"-help"
(
PassFlag
(
setMode
ShowUsage
))
Supported
,
Flag
"-print-libdir"
(
PassFlag
(
setMode
PrintLibdir
))
Supported
,
Flag
"V"
(
PassFlag
(
setMode
ShowVersion
))
Supported
,
Flag
"-version"
(
PassFlag
(
setMode
ShowVersion
))
Supported
,
Flag
"-numeric-version"
(
PassFlag
(
setMode
ShowNumVersion
))
Supported
,
Flag
"-info"
(
PassFlag
(
setMode
ShowInfo
))
Supported
,
Flag
"-supported-languages"
(
PassFlag
(
setMode
ShowSupportedLanguages
))
Supported
------- interfaces ----------------------------------------------------
,
Flag
"-show-iface"
(
HasArg
(
\
f
->
setMode
(
ShowInterface
f
)
"--show-iface"
))
Supported
------- primary modes ------------------------------------------------
,
Flag
"M"
(
PassFlag
(
setMode
DoMkDependHS
))
Supported
,
Flag
"E"
(
PassFlag
(
setMode
(
StopBefore
anyHsc
)))
Supported
,
Flag
"C"
(
PassFlag
(
\
f
->
do
setMode
(
StopBefore
HCc
)
f
addFlag
"-fvia-C"
))
Supported
,
Flag
"S"
(
PassFlag
(
setMode
(
StopBefore
As
)))
Supported
,
Flag
"-make"
(
PassFlag
(
setMode
DoMake
))
Supported
,
Flag
"-interactive"
(
PassFlag
(
setMode
DoInteractive
))
Supported
,
Flag
"e"
(
HasArg
(
\
s
->
updateMode
(
updateDoEval
s
)
"-e"
))
Supported
-- -fno-code says to stop after Hsc but don't generate any code.
,
Flag
"fno-code"
(
PassFlag
(
\
f
->
do
setMode
(
StopBefore
HCc
)
f
addFlag
"-fno-code"
addFlag
"-no-recomp"
))
Supported
]
setMode
::
CmdLineMode
->
String
->
ModeM
()
...
...
compiler/main/StaticFlags.hs
View file @
a7f88c2f
...
...
@@ -93,12 +93,12 @@ import Data.List
-----------------------------------------------------------------------------
-- Static flags
parseStaticFlags
::
[
String
]
->
IO
[
String
]
parseStaticFlags
::
[
String
]
->
IO
(
[
String
]
,
[
String
])
parseStaticFlags
args
=
do
ready
<-
readIORef
v_opt_C_ready
when
ready
$
throwDyn
(
ProgramError
"Too late for parseStaticFlags: call it before newSession"
)
(
leftover
,
errs
)
<-
processArgs
static_flags
args
(
leftover
,
errs
,
warns1
)
<-
processArgs
static_flags
args
when
(
not
(
null
errs
))
$
throwDyn
(
UsageError
(
unlines
errs
))
-- deal with the way flags: the way (eg. prof) gives rise to
...
...
@@ -109,7 +109,7 @@ parseStaticFlags args = do
let
unreg_flags
|
cGhcUnregisterised
==
"YES"
=
unregFlags
|
otherwise
=
[]
(
more_leftover
,
errs
)
<-
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
...
...
@@ -128,7 +128,8 @@ parseStaticFlags args = do
|
otherwise
=
[]
when
(
not
(
null
errs
))
$
ghcError
(
UsageError
(
unlines
errs
))
return
(
excess_prec
++
cg_flags
++
more_leftover
++
leftover
)
return
(
excess_prec
++
cg_flags
++
more_leftover
++
leftover
,
warns1
++
warns2
)
initStaticOpts
::
IO
()
initStaticOpts
=
writeIORef
v_opt_C_ready
True
...
...
@@ -149,54 +150,65 @@ static_flags :: [Flag IO]
static_flags
=
[
------- GHCi -------------------------------------------------------
Flag
"ignore-dot-ghci"
(
PassFlag
addOpt
)
,
Flag
"read-dot-ghci"
(
NoArg
(
removeOpt
"-ignore-dot-ghci"
))
Flag
"ignore-dot-ghci"
(
PassFlag
addOpt
)
Supported
,
Flag
"read-dot-ghci"
(
NoArg
(
removeOpt
"-ignore-dot-ghci"
))
Supported
------- ways --------------------------------------------------------
,
Flag
"prof"
(
NoArg
(
addWay
WayProf
))
,
Flag
"ticky"
(
NoArg
(
addWay
WayTicky
))
,
Flag
"parallel"
(
NoArg
(
addWay
WayPar
))
,
Flag
"gransim"
(
NoArg
(
addWay
WayGran
))
,
Flag
"smp"
(
NoArg
(
addWay
WayThreaded
))
-- backwards compat.
,
Flag
"debug"
(
NoArg
(
addWay
WayDebug
))
,
Flag
"ndp"
(
NoArg
(
addWay
WayNDP
))
,
Flag
"threaded"
(
NoArg
(
addWay
WayThreaded
))
,
Flag
"prof"
(
NoArg
(
addWay
WayProf
))
Supported
,
Flag
"ticky"
(
NoArg
(
addWay
WayTicky
))
Supported
,
Flag
"parallel"
(
NoArg
(
addWay
WayPar
))
Supported
,
Flag
"gransim"
(
NoArg
(
addWay
WayGran
))
Supported
,
Flag
"smp"
(
NoArg
(
addWay
WayThreaded
))
(
Deprecated
"Use -threaded instead"
)
,
Flag
"debug"
(
NoArg
(
addWay
WayDebug
))
Supported
,
Flag
"ndp"
(
NoArg
(
addWay
WayNDP
))
Supported
,
Flag
"threaded"
(
NoArg
(
addWay
WayThreaded
))
Supported
-- ToDo: user ways
------ Debugging ----------------------------------------------------
,
Flag
"dppr-debug"
(
PassFlag
addOpt
)
,
Flag
"dsuppress-uniques"
(
PassFlag
addOpt
)
,
Flag
"dppr-user-length"
(
AnySuffix
addOpt
)
,
Flag
"dopt-fuel"
(
AnySuffix
addOpt
)
,
Flag
"dno-debug-output"
(
PassFlag
addOpt
)
,
Flag
"dppr-debug"
(
PassFlag
addOpt
)
Supported
,
Flag
"dsuppress-uniques"
(
PassFlag
addOpt
)
Supported
,
Flag
"dppr-user-length"
(
AnySuffix
addOpt
)
Supported
,
Flag
"dopt-fuel"
(
AnySuffix
addOpt
)
Supported
,
Flag
"dno-debug-output"
(
PassFlag
addOpt
)
Supported
-- rest of the debugging flags are dynamic
--------- Profiling --------------------------------------------------
,
Flag
"auto-all"
(
NoArg
(
addOpt
"-fauto-sccs-on-all-toplevs"
))
Supported
,
Flag
"auto"
(
NoArg
(
addOpt
"-fauto-sccs-on-exported-toplevs"
))
Supported
,
Flag
"caf-all"
(
NoArg
(
addOpt
"-fauto-sccs-on-individual-cafs"
))
Supported
-- "ignore-sccs" doesn't work (ToDo)
,
Flag
"no-auto-all"
(
NoArg
(
removeOpt
"-fauto-sccs-on-all-toplevs"
))
Supported
,
Flag
"no-auto"
(
NoArg
(
removeOpt
"-fauto-sccs-on-exported-toplevs"
))
Supported
,
Flag
"no-caf-all"
(
NoArg
(
removeOpt
"-fauto-sccs-on-individual-cafs"
))
Supported
----- Linker --------------------------------------------------------
,
Flag
"static"
(
PassFlag
addOpt
)
,
Flag
"dynamic"
(
NoArg
(
removeOpt
"-static"
))
,
Flag
"rdynamic"
(
NoArg
(
return
()
))
-- ignored for compat w/ gcc
,
Flag
"static"
(
PassFlag
addOpt
)
Supported
,
Flag
"dynamic"
(
NoArg
(
removeOpt
"-static"
))
Supported
-- ignored for compat w/ gcc:
,
Flag
"rdynamic"
(
NoArg
(
return
()
))
Supported
----- RTS opts ------------------------------------------------------
,
Flag
"H"
(
HasArg
(
setHeapSize
.
fromIntegral
.
decodeSize
))
,
Flag
"Rghc-timing"
(
NoArg
(
enableTimingStats
))
Supported
,
Flag
"Rghc-timing"
(
NoArg
(
enableTimingStats
))
Supported
------ Compiler flags -----------------------------------------------
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
,
Flag
"fno-"
(
PrefixPred
(
\
s
->
isStaticFlag
(
"f"
++
s
))
(
\
s
->
removeOpt
(
"-f"
++
s
)))
Supported
-- Pass all remaining "-f<blah>" options to hsc
,
Flag
"f"
(
AnySuffixPred
(
isStaticFlag
)
addOpt
)
Supported
]
addOpt
::
String
->
IO
()
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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