Give locations of flag warnings/errors

diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 0789693..a748b47 100644 (file)
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -58,6 +58,7 @@ module SrcLoc (
        
        -- ** Constructing Located
        noLoc,
        
        -- ** Constructing Located
        noLoc,

+    mkGeneralLocated,

        
        -- ** Deconstructing Located
        getLoc, unLoc, 
        
        -- ** Deconstructing Located
        getLoc, unLoc, 

@@ -453,6 +454,9 @@ getLoc (L l _) = l
 noLoc :: e -> Located e
 noLoc e = L noSrcSpan e
 
 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)
 
 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 6f9c224..48033ae 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -42,6 +42,7 @@ import SrcLoc
 
 -- Other random utilities
 import ErrUtils
 
 -- Other random utilities
 import ErrUtils

+import CmdLineParser

 import Digraph
 import BasicTypes hiding (isTopLevel)
 import Panic      hiding (showException)
 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
 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))
       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'
 
 
       new_pkgs <- setDynFlags dflags'
 

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 8112dbb..dfdea62 100644 (file)
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -13,12 +13,15 @@ module CmdLineParser (
         processArgs, OptKind(..),
         CmdLineP(..), getCmdLineState, putCmdLineState,
         Flag(..), Deprecated(..),
         processArgs, OptKind(..),
         CmdLineP(..), getCmdLineState, putCmdLineState,
         Flag(..), Deprecated(..),

+        errorsToGhcException

   ) where
 
 #include "HsVersions.h"
 
 import Util
   ) where
 
 #include "HsVersions.h"
 
 import Util

+import Outputable

 import Panic
 import Panic

+import SrcLoc

 
 data Flag m = Flag
     {
 
 data Flag m = Flag
     {

@@ -44,36 +47,36 @@ data OptKind m                      -- Suppose the flag is -f
 
 processArgs :: Monad m
             => [Flag m] -- cmdline parser spec
 
 processArgs :: Monad m
             => [Flag m] -- cmdline parser spec

-            -> [String]              -- args
+            -> [Located String]      -- args

             -> m (
             -> 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)
 
                  )
 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 ->
       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
                         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'
               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
 
 
 
     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
 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
         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
 
         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
 
         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)
 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 e246b8b..7620d07 100644 (file)
--- 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 BasicTypes      ( SuccessFlag(..) )
 import Maybes          ( expectJust )
 import ParserCoreUtils ( getCoreModuleName )

-import SrcLoc          ( unLoc )
-import SrcLoc          ( Located(..) )
+import SrcLoc

 import FastString
 
 import Exception
 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
 
 -- 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
   = 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
        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
 
        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 14842b1..19e4af2 100644 (file)
--- 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 UniqFM           ( UniqFM )
 import Util
 import Maybes           ( orElse )

-import SrcLoc           ( SrcSpan )
+import SrcLoc

 import FastString
 import Outputable
 import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
 import FastString
 import Outputable
 import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )

@@ -1690,7 +1690,8 @@ glasgowExtsFlags = [
 -- -----------------------------------------------------------------------------
 -- Parsing the dynamic flags.
 
 -- -----------------------------------------------------------------------------
 -- 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
 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.
   --     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
       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
   return (dflags', leftover, warns)
 
 type DynP = CmdLineP DynFlags

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index af1da39..a030a19 100644 (file)
--- 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 )
 #include "HsVersions.h"
 
 import Bag             ( Bag, bagToList, isEmptyBag, emptyBag )

-import SrcLoc          ( SrcSpan )

 import Util            ( sortLe )
 import Outputable
 import Util            ( sortLe )
 import Outputable

-import SrcLoc          ( srcSpanStart, noSrcSpan )
+import SrcLoc

 import DynFlags                ( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags     ( opt_ErrorSpans )
 
 import DynFlags                ( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags     ( opt_ErrorSpans )
 

@@ -197,22 +196,25 @@ printBagOfWarnings dflags bag_of_warns
                EQ -> True
                GT -> False
 
                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 dflags warns
  = when (dopt Opt_WarnDeprecatedFlags dflags)
         (handleFlagWarnings' dflags warns)
 

-handleFlagWarnings' :: DynFlags -> [String] -> IO ()
+handleFlagWarnings' :: DynFlags -> [Located String] -> IO ()

 handleFlagWarnings' _ [] = return ()
 handleFlagWarnings' dflags warns
 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.
       -- 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)
 
       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
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
   | val == 0  = exitWith ExitSuccess

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 19e36eb..7ecc194 100644 (file)
--- 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
        --
        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
         handleFlagWarnings dflags' warns
 
        let

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index eea6b52..22f645e 100644 (file)
--- 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
 
 -----------------------------------------------------------------------------
 -- 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 c0a501e..aaab558 100644 (file)
--- 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 StaticFlags
 import CmdLineParser
 import Config

+import SrcLoc

 import Util
 import Panic
 
 import Util
 import Panic
 

@@ -27,23 +28,24 @@ import Data.List
 -----------------------------------------------------------------------------
 -- Static flags
 
 -----------------------------------------------------------------------------
 -- 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
 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
 
     -- 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 = []
 
 
     -- 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
 
     -- 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...
     -- 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.
 
     -- 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)
 
   return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
           warns1 ++ warns2)
 

@@ -181,8 +186,8 @@ isStaticFlag f =
     "funfolding-keeness-factor"
      ]
 
     "funfolding-keeness-factor"
      ]
 

-unregFlags :: [String]
-unregFlags = 
+unregFlags :: [Located String]
+unregFlags = map (mkGeneralLocated "in unregFlags")

    [ "-optc-DNO_REGS"
    , "-optc-DUSE_MINIINTERPRETER"
    , "-fno-asm-mangling"
    [ "-optc-DNO_REGS"
    , "-optc-DUSE_MINIINTERPRETER"
    , "-fno-asm-mangling"

diff --git a/ghc/Main.hs b/ghc/Main.hs
index a974716..b75548b 100644 (file)
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -41,6 +41,7 @@ import BasicTypes     ( failed )
 import ErrUtils
 import FastString
 import Outputable
 import ErrUtils
 import FastString
 import Outputable

+import SrcLoc

 import Util
 import Panic
 
 import Util
 import Panic
 

@@ -77,7 +78,8 @@ main =
         mbMinusB | null minusB_args = Nothing
                  | otherwise = Just (drop 2 (last minusB_args))
 
         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
 
   -- 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.
      -- 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 
     (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
 
 -- -----------------------------------------------------------------------------
 -- 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, "", []) 
 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)
 
   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.
 
   -- 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
 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')

 
 
 -- ----------------------------------------------------------------------------
 
 
 -- ----------------------------------------------------------------------------