Commit fc9bbbab authored by Ian Lynagh's avatar Ian Lynagh

Give locations of flag warnings/errors

parent 54280054
......@@ -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)
......
......@@ -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'
......
......@@ -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_arg : spare) errs warns
Nothing -> process spec args (locArg : 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)
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
-----------------------------------------------------------------------------
......
......@@ -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"
......
......@@ -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')
-- ----------------------------------------------------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment