Give locations of flag warnings/errors

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)
 

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'
 

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)
+

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

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

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

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

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)
 
 -----------------------------------------------------------------------------
 

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"

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')
 
 
 -- ----------------------------------------------------------------------------