diff options
| -rw-r--r-- | compiler/basicTypes/SrcLoc.lhs | 4 | ||||
| -rw-r--r-- | compiler/ghci/InteractiveUI.hs | 8 | ||||
| -rw-r--r-- | compiler/main/CmdLineParser.hs | 36 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 9 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 10 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.lhs | 16 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 4 | ||||
| -rw-r--r-- | compiler/main/HeaderInfo.hs | 15 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 25 | ||||
| -rw-r--r-- | ghc/Main.hs | 17 |
10 files changed, 85 insertions, 59 deletions
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 0789693287..a748b47822 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -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) diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 6f9c2248be..48033ae709 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -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' diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 8112dbb785..dfdea62f25 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -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) + diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index e246b8b670..7620d074bd 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 14842b1551..19e4af2951 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index af1da394a3..a030a19648 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 19e36eb293..7ecc1942e9 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index eea6b52fc2..22f645efd5 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -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) ----------------------------------------------------------------------------- diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index c0a501e8e3..aaab558c69 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -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" diff --git a/ghc/Main.hs b/ghc/Main.hs index a974716836..b75548be5f 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -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') -- ---------------------------------------------------------------------------- |